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

Я использую этот макрос для более 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 записей, и я не знаю, когда он закончится.

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

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

Источник

5 ответов

Решение

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

Источник

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

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

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

Источник

Ваш код обновляет значения в столбце 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
Источник

Вставьте как показано

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

После команд 2 Range ("E" & row) добавьте вышеприведенное.

Таким образом, после замены значения на NULL нет смысла искать в остальной части столбца H, поскольку E равно NULL. Таким образом, если E является NULL в строке 2, то нет смысла искать строку 3-1000 в столбце H, поэтому вырвитесь из цикла и перейдите к E3.

Также порядок столбца H является критическим. Если возможно, наиболее распространенные совпадения должны быть в верхней части столбца H, чтобы не приходилось искать столько H, сколько было бы, если бы список был неупорядоченным или случайным.

Источник

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

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

Вместо перехода от ячейки к ячейке в столбце 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
Источник
Другие вопросы по тегам