Faça sua pergunta de acompanhamento - Posso executar essa macro mais rapidamente? - Estou enviando minha resposta aqui e votando para fechar essa questão como uma duplicata.
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.
Apenas por completo, aqui está uma rotina que remove espaços extras da coluna E
Sub ConsecSpace()
Dim c As Range
Dim lastrow As Integer
lastrow = ActiveSheet.Cells(Rows.Count, "E").End(xlUp).Row
Dim strValue As String
For Each c In Range("E2:E" & lastrow)
strValue = c.Value
Do While InStr(1, strValue, " ")
strValue = Replace(strValue, " ", " ")
Loop
c = strValue
Next
End Sub