Estou usando esta macro para mais de 1000 entradas. O código em si funciona do jeito 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 leva uma eternidade para ser executada; para vocês terem uma ideia, essa macro está rodando há 4 horas em +1000 entradas e não sei quando vai terminar.
Existe uma maneira de otimizar esse código para ser executado mais rapidamente e não comprometer a integridade do próprio código?
Toda e qualquer ajuda será apreciada.
Responder1
Se bem entendi, você deseja pegar todos os valores da coluna H e excluí-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 na coluna H. Em seguida, ele passa por cada célula da coluna E, analisa-a em uma matriz, pesquisa cada membro dessa matriz na matriz keep e, se encontrado, exclui esse membro da matriz. Depois de passar pela célula, ele reimprime o array com os encontrados faltando.
Matrizes geralmente são mais rápidas do que ir item por item, mas além disso, estamos criando nossa própria função em vez de usar o métodolento Find and Replacemétodo. O único problema é que pode haver espaços extras nos dados. Nesse caso, podemos executar uma localização rápida e substituir por isso. Achei mais fácil definir os membros do array como nada, em vez de redimensionar o array e mover os elementos.
Responder2
Você já tentou configurar os cálculos para manual? (No Excel 2013)Formulas - Calculation Options - Manual
Parece que sua intenção é remover todas as ocorrências dos valores da coluna "H" nos valores da coluna "E".
Já pensou em exportar o conteúdo e utilizar outra ferramenta que não o Excel para realizar as alterações desejadas?
Responder3
Seu código está atualizando os valores na coluna E, removendo quaisquer valores encontrados na coluna H. No entanto, ele está fazendo isso de maneira muito ineficiente, observando apenas uma célula de 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ê olha para uma única célula, é mais fácil usar um objeto Range para acessá-la, em vez de combinar uma string para a coluna e um número para a linha.
Este código deve fazer a mesma coisa que o seu, mas processa todos os valores na coluna E de uma só vez usando o método Substituir do objeto Range (que é a mesma funcionalidade de quando você substitui tudo na interface do usuário). Isso deve ser muito mais rápido.
Na primeira Replacechamada abaixo, o Trueargumento final indica uma correspondência que diferencia maiúsculas de minúsculas. Se você quiser uma correspondência que não diferencie maiúsculas de minúsculas, altere 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
Responder4
Chego tarde à festa, mas gostaria de dar a minha opinião às soluções.
Este código irá procurar valores em column H(8) e substituí-los ""na coluna E.
Em vez de ir célula por célula na coluna E ele faz a substituição na coluna completa, então 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