0

试图加速运行超过 50,000 行的宏！

我有两种方法可以执行相同的 vba 宏

    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 回答