Posso rodar essa macro mais rápido? [duplicado]

Question

Estou usando essa macro para mais de 1.000 entradas. O código em si funciona da maneira que eu quero.

Option Explicit
Sub DoTheThing()
 Dim keepValueCol As String
 keepValueCol = "H"

 Dim row As Integer
 row = 2

 Dim keepValueRow As Integer
 keepValueRow = 1

 Do While (Range("E" & row).Value <> "")

    Do While (Range(keepValueCol & keepValueRow).Value <> "")

    Range("E" & row).Value = Replace(Range("E" & row).Value, Range(keepValueCol & keepValueRow).Value, "")
    Range("E" & row).Value = Trim(Replace(Range("E" & row).Value, "  ", " "))

    keepValueRow = keepValueRow + 1
    Loop


 keepValueRow = 1
 row = row + 1
 Loop

End Sub

O problema que estou tendo é que a macro demora uma eternidade para ser executada; para você ter uma ideia, essa macro está sendo executada por 4 horas com +1000 entradas e não sei quando isso vai terminar.

Existe alguma maneira de otimizar este código para rodar mais rápido e não comprometer a integridade do próprio código?

Toda e qualquer ajuda será apreciada.

    

Answer 1

Se eu entendi, você quer pegar todos os valores da coluna H e deletá-los da coluna E? Eu faria isso com alguns arrays para acelerar -

Option Explicit
Sub DoTheThing()
Application.ScreenUpdating = False
Dim lastrow As Integer
'Find last row in column H to size our array
lastrow = ActiveSheet.Cells(Rows.Count, "H").End(xlUp).row

'Declare the array and then resize it to fit column H
Dim varkeep() As Variant
ReDim varkeep(lastrow - 1)

'Load column H into the array
Dim i As Integer
For i = 0 To lastrow - 1
    varkeep(i) = Range("H" & i + 1)
Next

Dim member As Variant
'find last row in column E
lastrow = ActiveSheet.Cells(Rows.Count, "E").End(xlUp).row

'loop each cell in column E starting in row 2 ending in lastrow
For i = 2 To lastrow
    'Make a new array
    Dim myArray As Variant
    'Load the cell into the array
    myArray = Split(Cells(i, 5), " ")
    Dim k As Integer
    'for each member of this array
    For k = LBound(myArray) To UBound(myArray)
        member = myArray(k)
        'call the contains function to check if the member exists in column H
        If Contains(varkeep, member) Then
            'if it does, set it to nothing
            myArray(k) = vbNullString
        End If
    Next
    'let's reprint the array to the cell before moving on to the next cell in column E
    Cells(i, 5) = Trim(Join(myArray, " "))
Next
Application.ScreenUpdating = True
End Sub


Function Contains(arr As Variant, m As Variant) As Boolean
    Dim tf As Boolean
    'Start as false
    tf = False
    Dim j As Integer
        'Search for the member in the keeparray
        For j = LBound(arr) To UBound(arr)
            If arr(j) = m Then
                'if it's found, TRUE
                tf = True
                Exit For
            End If
        Next j
        'Return the function as true or false for the if statement
        Contains = tf
End Function

Isso cria uma matriz fora da coluna H. Em seguida, ela passa por cada célula na coluna E, analisa-a em uma matriz, pesquisa cada membro dessa matriz na matriz keep e, se encontrada, exclui esse membro da matriz. Depois de passar pela célula, ele reimprime a matriz com os que estão faltando.

Os arrays geralmente são mais rápidos do que item por item, mas, além disso, estamos criando nossa própria função em vez de usar o método slow Find and Replace . O único problema é que pode haver espaços extras nos dados. Se assim for, podemos executar um rápido encontrar e substituir por isso. Achei mais fácil definir os membros da matriz como nada, em vez de redimensionar a matriz e mover os elementos.

    

Answer 2

Você já tentou definir os cálculos como manuais? (No Excel 2013) Formulas - Calculation Options - Manual

Parece que sua intenção é remover todas as ocorrências dos valores na coluna "H" nos valores da coluna "E".

Você já pensou em exportar o conteúdo e usar uma ferramenta diferente do excel para realizar as alterações desejadas?

    

Answer 3

Seu código está atualizando os valores na coluna E, removendo todos os valores encontrados na coluna H. No entanto, está fazendo isso de forma muito ineficiente, observando apenas uma célula a cada vez. Você pode fazer muito melhor lidando com todo o intervalo na coluna E de uma só vez. Além disso, mesmo quando você está olhando para uma única célula, é mais fácil usar um objeto Range para acessá-lo, em vez de combinar uma string para a coluna e um número para a linha.

Esse código deve fazer o mesmo que o seu, mas processa todos os valores da coluna E de uma só vez usando o método Replace do objeto Range (que é a mesma funcionalidade de quando você faz um Replace All na UI). Isso deve ser muito mais rápido.

Na primeira chamada Replace abaixo, o True para o argumento final indica uma correspondência entre maiúsculas e minúsculas. Se você quiser uma correspondência sem distinção entre maiúsculas e minúsculas, altere isso para False .

Option Explicit
Sub DoTheThing()

  Dim UpdateRange As Range, ReplaceCell As Range, dummy As Boolean

  Set UpdateRange = Range("E2", Range("E2").End(xlDown))
  Set ReplaceCell = Range("H1")

  Do While (ReplaceCell.Value <> "")
    dummy = UpdateRange.Replace(ReplaceCell.Value, "", xlPart, , True)
    dummy = UpdateRange.Replace("  ", " ", xlPart)
    Set ReplaceCell = ReplaceCell.Offset(1, 0)
  Loop

End Sub

    

Answer 4

Inserir como mostrado

    if (Range("E"&row).value="") then
      Exit Do
    End if

Após os 2 comandos Range ("E" & row) , adicione o anterior.

Dessa forma, uma vez que você substitua o valor por NULL, não há nenhum ponto procurando o restante da coluna H, já que E é NULL. Então, se E é NULL na linha 2, não há nenhum ponto procurando a linha 3-1000 na coluna H, então saia do loop e vá para o E3.

Além disso, a ordem da coluna H é crítica. Se possível, as correspondências mais comuns devem estar no topo da coluna H, para que não seja preciso pesquisar tanto quanto H se a lista fosse desordenada ou aleatória.

    

Answer 5

Estou me juntando tarde à festa, mas gostaria de colocar meus dois centavos nas soluções.

Este código irá procurar por valores em column H (8) e substituí-los por "" na coluna E.

Em vez de percorrer célula por célula na coluna E, ele faz a substituição na coluna completa. Portanto, ele fará um único loop nos valores da coluna H.

Public Sub big_search()
Dim wkb As Workbook
Dim wks As Worksheet
Set wkb = ThisWorkbook
Set wks = wkb.Sheets(1)
thisrow = 1
existe = True
inicio = Format(Now(), "yyyymmddhhmmss")
While existe
    ' keep in mind that the column H is the 8th
    selectionvalue = wks.Cells(thisrow, 8)
    If selectionvalue <> "" Then
        wks.Columns("E").Replace What:=selectionvalue, Replacement:="", SearchOrder:=xlByColumns, MatchCase:=True
        thisrow = thisrow + 1
    Else
        existe = False
    End If
Wend
fin = Format(Now(), "yyyymmddhhmmss")
a = MsgBox(fin - inicio & " seconds", vbOKOnly)
End Sub