☰

Могу ли я запустить этот макрос быстрее?

tag-icon • tag-icon microsoft-excel vba macros
Могу ли я запустить этот макрос быстрее?

Я использую этот макрос для более чем 1000 записей. Сам код работает так, как я хочу.

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

Проблема, с которой я столкнулся, заключается в том, что макрос выполняется очень долго. Чтобы вы имели представление, этот макрос выполняется уже 4 часа при более чем 1000 записях, и я не знаю, когда он закончится.

Есть ли способ оптимизировать этот код, чтобы он работал быстрее и не ставил под угрозу целостность самого кода?

Любая помощь будет оценена по достоинству.

решение1

Если я правильно вас понял, вы хотите взять все значения в столбце H и удалить их из столбца E? Я бы сделал это с помощью некоторых массивов, чтобы ускорить процесс -

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

Это создает массив из столбца H. Затем он проходит по каждой ячейке в столбце E, разбирает ее в массив, ищет каждый элемент этого массива в массиве keep и, если он найден, удаляет этот элемент массива. После прохождения ячейки он перепечатывает массив с пропущенными найденными элементами.

Массивы, как правило, работают быстрее, чем поэлементный обход, но, кроме того, мы создаем собственную функцию, а не используеммедленный Find and Replacemethod. Единственная проблема в том, что в данных могут быть лишние пробелы. Если это так, мы можем выполнить быстрый поиск и замену для этого. Я обнаружил, что проще установить элементы массива на ноль, чем изменять размер массива и перемещать элементы.

решение2

Пробовали ли вы настроить вычисления вручную? (В Excel 2013)Formulas - Calculation Options - Manual

Похоже, вы намереваетесь удалить все вхождения значений из столбца «H» в значения в столбце «E».

Рассматривали ли вы возможность экспорта контента и использования другого инструмента, помимо Excel, для внесения желаемых изменений?

решение3

Ваш код обновляет значения в столбце E, удаляя любые значения, которые он находит в столбце H. Однако он делает это очень неэффективно, просматривая только одну ячейку каждый раз. Вы можете добиться гораздо большего, имея дело со всем диапазоном в столбце E сразу. Кроме того, даже когда вы просматриваете одну ячейку, проще использовать объект Range для доступа к ней, чем объединять строку для столбца и число для строки.

Этот код должен делать то же самое, что и ваш, но он обрабатывает все значения в столбце E одновременно, используя метод Replace объекта Range (то есть ту же функциональность, что и при выполнении Replace All в пользовательском интерфейсе). Это должно быть намного быстрее.

В первом Replaceвызове ниже Trueдля последнего аргумента указывается соответствие с учетом регистра. Если вы хотите соответствие без учета регистра, измените это на 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

решение4

Я присоединяюсь к вечеринке с опозданием, но хотел бы внести свои пять копеек в решения.

Этот код будет искать значения в column H(8) и заменять их ""в столбце E.

Вместо того, чтобы перебирать ячейки по столбцу E, он выполняет замену по всему столбцу. Таким образом, он выполнит один цикл по значениям в столбце 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

Связанный контент