☰

このマクロをより速く実行できますか?

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 の値を更新しています。ただし、毎回 1 つのセルのみを参照しているため、非常に非効率的です。列 E の範囲全体を一度に処理すると、はるかに効率的になります。また、1 つのセルを参照している場合でも、列の文字列と行の数値を組み合わせるよりも、Range オブジェクトを使用してアクセスする方が簡単です。

このコードはあなたのコードと同じことを行うはずですが、Range オブジェクトの Replace メソッドを使用して列 E のすべての値を一度に処理します (これは UI ですべて置換を実行する場合と同じ機能です)。これにより、処理がはるかに高速になります。

以下の最初の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）の値を探し、列Ecolumn Hに置き換えます。""

列 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

関連情報