Estoy usando esta macro para más de 1000 entradas. El código en sí funciona como quiero.
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
El problema que tengo es que la Macro tarda una eternidad en ejecutarse; Para darle una idea, esta macro se ejecuta durante 4 horas en +1000 entradas y no sé cuándo terminará.
¿Hay alguna manera de optimizar este código para que se ejecute más rápido y no comprometa la integridad del código en sí?
Cualquier ayuda será apreciada.
Respuesta1
Si te entiendo, ¿quieres tomar todos los valores de la columna H y eliminarlos de la columna E? Haría eso con algunas matrices para acelerarlo.
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
Esto crea una matriz a partir de la columna H. Luego revisa cada celda de la columna E, la analiza en una matriz, busca cada miembro de esa matriz en la matriz de mantenimiento y, si la encuentra, elimina ese miembro de la matriz. Después de revisar la celda, vuelve a imprimir la matriz sin las encontradas.
Las matrices son generalmente más rápidas que ir elemento por elemento, pero además, estamos creando nuestra propia función en lugar de usar ellento Find and Replacemétodo. El único problema es que puede haber espacios adicionales dentro de los datos. Si es así, podemos ejecutar una búsqueda rápida y reemplazarlo. Me resultó más fácil establecer los miembros de la matriz en nada en lugar de cambiar el tamaño de la matriz y mover los elementos.
Respuesta2
¿Has intentado configurar los cálculos en manual? (En Excel 2013)Formulas - Calculation Options - Manual
Parece que su intención es eliminar todas las apariciones de los valores de la columna "H" en los valores de la columna "E".
¿Ha considerado exportar el contenido y utilizar una herramienta distinta de Excel para realizar los cambios que desea?
Respuesta3
Su código actualiza los valores en la columna E eliminando los valores que encuentra en la columna H. Sin embargo, lo hace de manera muy ineficiente al mirar solo una celda cada vez. Puede hacerlo mucho mejor si trata todo el rango de la columna E a la vez. Además, incluso cuando estás mirando una sola celda, es más fácil usar un objeto Rango para acceder a ella en lugar de combinar una cadena para la columna y un número para la fila.
Este código debería hacer lo mismo que el suyo, pero procesa todos los valores en la columna E a la vez usando el método Reemplazar del objeto Rango (que es la misma funcionalidad que cuando realiza Reemplazar todo en la interfaz de usuario). Esto debería ser mucho más rápido.
En la primera Replacellamada a continuación, el Trueargumento final indica una coincidencia que distingue entre mayúsculas y minúsculas. Si desea una coincidencia que no distinga entre mayúsculas y minúsculas, cámbiela a 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
Respuesta4
Me sumo tarde a la fiesta, pero me gustaría aportar mi granito de arena a las soluciones.
Este código buscará valores en column H(8) y los reemplazará por los ""de la columna E.
En lugar de ir celda por celda en la columna E, realiza el reemplazo en la columna completa, por lo que hará un solo bucle en los valores de la columna 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