☰

我可以更快地运行这个宏吗？

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

我遇到的问题是宏需要很长时间才能运行；举个例子，这个宏在 +1000 个条目上运行了 4 个小时，我不知道它什么时候结束。

有没有办法可以优化这段代码，使其运行得更快，并且不损害代码本身的完整性？

任何帮助都将受到感谢。

答案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 列中的每个单元格，将其解析为一个数组，根据保留数组搜索该数组的每个成员，如果找到，则删除该数组成员。遍历单元格后，它会重新打印缺少找到的数组。

数组通常比逐项执行速度更快，但此外，我们正在创建自己的函数，而不是使用慢的 Find and Replace方法。唯一的问题是数据中可能存在多余的空格。如果是这样，我们可以快速查找并替换它。我发现将数组的成员设置为空比重新调整数组大小并移动元素更容易。

答案2

您是否尝试过将计算设置为手动？（在 Excel 2013 中）Formulas - Calculation Options - Manual

看起来您的意图是删除“E”列中的值中“H”列中的所有值。

您是否考虑过导出内容并使用 Excel 以外的工具来执行您想要的更改？

答案3

您的代码通过删除在 H 列中找到的任何值来更新 E 列中的值。但是，每次只查看一个单元格，效率非常低。通过一次处理 E 列中的整个范围，您可以做得更好。此外，即使您正在查看单个单元格，使用 Range 对象来访问它也比将列的字符串和行的数字组合起来更容易。

此代码应执行与您的代码相同的操作，但它使用 Range 对象的 Replace 方法一次性处理 E 列中的所有值（这与在 UI 中执行 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

我参加这个聚会已经晚了，但我愿意为解决方案贡献自己的力量。

此代码将在 (8) 中查找值column H并将其替换为""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

相关内容