Jump to content

Optimização de Código


OutOfMemory
 Share

Recommended Posts

Olá, desde já peço desculpa caso já exista um tópico semelhante, mas caso sim não o encontrei e estou a precisar de ajuda.

Apenas sou iniciado em VBA e ainda não sei muito, no entanto estou a afazer um código que vai verificar se em uma coluna "B" existe valores repetidos, caso sim nos valores iguais vai verificar na coluna "C" qual possui o maior valor, copiando o que tiver o menor para uma 2º tabela eliminando-o da 1º. O código já faz o pretendido no entanto preciso de corre-lo em tabelas com 60 mil linhas ou mais, e quando testo em tabelas com 5 mil linhas ou 10 mil linhas, o código dura entre 6 a 15 minutos a correr ( isto com sorte ). A minha questão é como posso optimizar o meu códiogo, se devo mudar o meu ciclo para um ciclo for each ou devo manter o Do While?

Aqui vai o código que fiz:

Function Copia()

Worksheets("Sheet1").Range("A1:AQ1").Copy _
Destination:=Worksheets("Sheet2").Range("A1")

Dim lRow As Long
Dim lRow2 As Long
Dim Row As Long
Dim contA As Long
Dim contB As Long
Dim t As Double

lRow = 5000
Row = 2
contA = 0
contB = 0

Application.ScreenUpdating = False
ViewMode = Activewindow.View
Activewindow.View = xlNormalView
Application.EnableEvents = False
Application.DisplayStatusBar = False

ActiveSheet.DisplayPageBreaks = False
lRow2 = lRow - 1
t = Timer

 Do While lRow > 2


		If (Cells.Item(lRow, "B") <> Cells.Item(lRow2, "B")) Then

			lRow = lRow - 1
			lRow2 = lRow - 1

		Else

			If (Cells.Item(lRow, "C") > Cells.Item(lRow2, "C")) Then

				Sheets("Sheet1").Rows(lRow2).Copy Sheets("Sheet2").Rows(Row)
				Rows(lRow2).Delete
				lRow = lRow - 1
				Row = Row + 1
				contA = contA + 1


			Else

				Sheets("Sheet1").Rows(lRow).Copy Sheets("Sheet2").Rows(Row)
				Rows(lRow).Delete
				lRow = lRow - 1
				Row = Row + 1
				contB = contB + 1

			End If

			lRow2 = lRow2 - 1

	   End If

Loop

Application.DisplayStatusBar = True
Activewindow.View = ViewMode
Application.ScreenUpdating = False
MsgBox "A = " & contA & " B = " & contB & "Duracao : " & (Timer - t) / 60

End Function
Link to comment
Share on other sites

Eu já consegui este código que parece ser mais rápido, no entanto quando chega à parte do "rngDel.Delete" dá erro "Run-time error 1004 " "Application-defined or object-defined error".

Function Copia()
Debug.Print Timer
Dim shtSrc As Worksheet, shtDest As Worksheet
Dim lRow As Long, Row As Long, viewmode
Dim countA As Long, countB As Long
Dim t As Double, rw As Range, rngDel As Range

lRow = 5000
Row = 2
countA = 0
countB = 0

Set shtSrc = Worksheets("Sheet1")
Set shtDest = Worksheets("Sheet2")

shtSrc.Range("A1:AQ1").Copy Destination:=shtDest.Range("A1")

Application.ScreenUpdating = False
viewmode = Activewindow.View
Activewindow.View = xlNormalView
Application.EnableEvents = False
Application.DisplayStatusBar = False

ActiveSheet.DisplayPageBreaks = False

t = Timer

 Do While lRow > 2

		Set rw = shtSrc.Rows(lRow)

		If (rw.Cells(2) = rw.Cells(2).Offset(-1, 0)) Then

			If (rw.Cells(3) > rw.Cells(3).Offset(-1, 0)) Then
				rw.Offset(-1, 0).Copy shtDest.Rows(Row)
				AddToRange rngDel, rw.Offset(-1, 0)
				countA = countA + 1
			Else
				rw.Copy shtDest.Rows(Row)
				AddToRange rngDel, rw
				countB = countB + 1
			End If

			Row = Row + 1


	 End If

	 lRow = lRow - 1

Loop


Debug.Print Timer
'anything to delete?
If Not rngDel Is Nothing Then
	rngDel.Delete
End If

Application.DisplayStatusBar = True
Activewindow.View = viewmode
Application.ScreenUpdating = False
Debug.Print Timer
Debug.Print "A = " & countA & " B = " & countB


End Function

'utility sub for building up a range
Sub AddToRange(rngTot, rng)
If rngTot Is Nothing Then
	Set rngTot = rng
Else
	Set rngTot = Application.Union(rng, rngTot)
End If
End Sub

Alguma sugestão de como corrigir o erro?

PS: Caso mude o .Delete para .Clear passa a dar, no entanto não com o resultado pretendido.

Link to comment
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now
 Share

×
×
  • Create New...

Important Information

By using this site you accept our Terms of Use and Privacy Policy. We have placed cookies on your device to help make this website better. You can adjust your cookie settings, otherwise we'll assume you're okay to continue.