☰

我可以更快地運行這個宏嗎？

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 列之外建立一個陣列。成員。在遍歷單元格後，它會重新列印數組，但發現的數組丟失了。

數組通常比逐項處理更快，但此外，我們正在創建自己的函數而不是使用慢的 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最後一個參數的 for 表示區分大小寫的匹配。如果您想要不區分大小寫的匹配，請將其變更為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

相關內容