0

50,000 行を超えるマクロを高速化しようとしています。

同じ vba マクロを実行するには 2 つの方法があります

    Sub deleteCommonValue()
Dim aRow, bRow As Long
Dim colB_MoreFirst, colB_LessFirst, colB_Second, colC_MoreFirst, colC_LessFirst, colC_Second As Integer
Dim colD_First, colD_Second As Integer

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

aRow = 2
bRow = 3

colB_MoreFirst = Range("B" & aRow).Value + 0.05
colB_LessFirst = Range("B" & aRow).Value - 0.05
colB_Second = Range("B" & bRow).Value
colC_MoreFirst = Range("C" & aRow).Value + 0.05
colC_LessFirst = Range("C" & aRow).Value - 0.05
colC_Second = Range("C" & bRow).Value
colD_First = Range("D" & aRow).Value
colD_Second = Range("D" & bRow).Value

Do

If colB_Second <= colB_MoreFirst And colB_Second >= colB_LessFirst Then

    If colC_Second <= colC_MoreFirst And colC_Second >= colC_LessFirst Then

        If colD_Second = colD_First Or colD_Second > colD_First Then
            Range(bRow & ":" & bRow).Delete
           'bRow delete, assign new value to bRow
           colB_Second = Range("B" & bRow).Value
           colC_Second = Range("C" & bRow).Value
           colD_Second = Range("D" & bRow).Value
           '-----------------------------------------------------
        Else
            Range(aRow & ":" & aRow).Delete
            bRow = aRow + 1

            'aRow value deleted, assign new value to aRow and bRow
            colB_MoreFirst = Range("B" & aRow).Value + 0.05
            colB_LessFirst = Range("B" & aRow).Value - 0.05
            colB_Second = Range("B" & bRow).Value
            colC_MoreFirst = Range("C" & aRow).Value + 0.05
            colC_LessFirst = Range("C" & aRow).Value - 0.05
            colC_Second = Range("C" & bRow).Value
            colD_First = Range("D" & aRow).Value
            colD_Second = Range("D" & bRow).Value
            '-----------------------------------------------------
        End If

    Else
        bRow = bRow + 1
        'Assign new value to bRow
        colB_Second = Range("B" & bRow).Value
        colC_Second = Range("C" & bRow).Value
        colD_Second = Range("D" & bRow).Value
        '-----------------------------------------------------
    End If

Else
    bRow = bRow + 1
    'Assign new value to bRow
    colB_Second = Range("B" & bRow).Value
    colC_Second = Range("C" & bRow).Value
    colD_Second = Range("D" & bRow).Value
    '-----------------------------------------------------
End If
If IsEmpty(Range("D" & bRow).Value) = True Then
    aRow = aRow + 1
    bRow = aRow + 1
    'finish compare aRow, assign new value to aRow and bRow
    colB_MoreFirst = Range("B" & aRow).Value + 0.05
    colB_LessFirst = Range("B" & aRow).Value - 0.05
    colB_Second = Range("B" & bRow).Value
    colC_MoreFirst = Range("C" & aRow).Value + 0.05
    colC_LessFirst = Range("C" & aRow).Value - 0.05
    colC_Second = Range("C" & bRow).Value
    colD_First = Range("D" & aRow).Value
    colD_Second = Range("D" & bRow).Value
    '-----------------------------------------------------

End If
Loop Until IsEmpty(Range("D" & aRow).Value) = True

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = False

End Sub

また

Sub deleteCommonValue()
Dim aRow, bRow As Long
Application.ScreenUpdating = False
aRow = 2
bRow = 3

Do
If Range("B" & bRow).Value <= (Range("B" & aRow).Value + 0.05) _
    And Range("B" & bRow).Value >= (Range("B" & aRow).Value - 0.05) Then

    If Range("C" & bRow).Value <= (Range("C" & aRow).Value + 0.05) _
        And Range("C" & bRow).Value >= (Range("C" & aRow).Value - 0.05) Then

        If Range("D" & bRow).Value = (Range("D" & aRow).Value) _
            Or Range("D" & bRow).Value > (Range("D" & aRow).Value) Then
            Range(bRow & ":" & bRow).Delete
        Else
            Range(aRow & ":" & aRow).Delete
            bRow = aRow + 1
            Range("A" & aRow).Select
        End If

    Else
        bRow = bRow + 1
        Range("A" & bRow).Select

    End If

Else
    bRow = bRow + 1
    Range("A" & bRow).Select
End If
If IsEmpty(Range("D" & bRow).Value) = True Then
    aRow = aRow + 1
    bRow = aRow + 1
End If
Loop Until IsEmpty(Range("D" & aRow).Value) = True

End Sub

行を複数のシートに分割するのが最善の選択肢かどうかわかりませんか?

4

1 に答える 1

1

次のように、すべての値を 2D バリアント配列に読み込みます。

Dim Vals() as variant
Vals = ActiveSheet.UsedRange.Value

次に、範囲に何度もアクセスするのではなく、配列内のすべての値をループします。削除する行のコレクションまたはリストを作成してから、それらを一度に削除します。

それは物事をスピードアップするのに役立つはずです。50k行をメモリに読み込むことができると思いますが、すべてを単一の配列に収めようとするのではなく、一度に数千行を読み取る必要があるかもしれません...

于 2013-06-25T19:20:10.840 に答える