OutOfMemory Posted October 27, 2015 at 04:06 PM Report Share #589202 Posted October 27, 2015 at 04:06 PM 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 More sharing options...
OutOfMemory Posted October 29, 2015 at 09:41 AM Author Report Share #589282 Posted October 29, 2015 at 09:41 AM 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 More sharing options...
Recommended Posts
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 accountSign in
Already have an account? Sign in here.
Sign In Now