Question

我是VBA的新手，因为它让我的工作变得如此简单，我尝试不时编写一些代码，一切正常，除了这个，我已经尝试过屏幕更新和状态Bar方法但它仍然很慢。关于如何改进的任何想法？哎呀

    Sub DW()
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Dim i As Long
    Dim LastRow As Long
    LastRow = Cells(Rows.Count, &quot;A&quot;).End(xlUp).Row

    i = 1
    Do Until i > LastRow
    If Range("B" & i) = Range(B & i + 1) Then
    Range("L" & i) = Range("L" & i) + Range("L" & i + 1)
    Range("M" & i) = Range("M" & i) + Range("M" & i + 1)
    Range("N" & i) = Range("N" & i) + Range("N" & i + 1)
    Range("O" & i) = Range("O" & i) + Range("O" & i + 1)
    Range("P" & i) = Range("P" & i) + Range("P" & i + 1)
    Range("Q" & i) = Range("Q" & i) + Range("Q" & i + 1)
    Range("A" & i + 1).EntireRow.Delete
    LastRow = LastRow - 1

    Else
    i = i + 1
    End If
    Loop
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    End Sub

Answer 1

这就是你的代码所做的事情;我测试了1k行数据，它比你的代码快。（更新了ja72＆＃39;输入）

Dim i As Long
Dim LastRow As Long

    If Range("B1") = Range("B2") Then
        Rows(1).Copy
        Rows(1).Insert Shift:=xlDown
        LastRow = Cells(Rows.Count, 1).End(xlUp).Row
        Cells(1, 12).Formula = "=SUM(L2:L" & LastRow & ")"
        Cells(1, 12).Resize(, 5).FillRight
    End If

    Range("L1").Resize(1,10).Value = Range("L1").Resize(1,10).Value

    Rows(2 & ":" & Rows.Count).Delete

Answer 2

下面的代码首先解决了范围选择的字符串数学问题。而不是.Range("A" & i)而是最好使用.Offset()或.Cells()。此外，它明确表示我们在数学发生时处理值而不是范围。建议始终在隐含的位置键入.Value。

Sub DW()
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Dim i As Long
    Dim LastRow As Long
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Dim r As Range, g As Range
    ' Set the start of the optimization loop
    Set r = Range("B1")
    ' While still inside the data
    Do While r.Row <= LastRow
        ' Check this value with value of next row
        If r.Value = r.Offset(1, 0).Value Then
            Set g = r.Offset(0, 10) ' Pick column "L" of same row as r
            Go from "L" to "Q"
            For i = 1 To 6
                'Add values one by one with row below
                g.Offset(0, i - 1).Value = _
                    g.Offset(0, i - 1).Value + g.Offset(1, i - 1).Value
            Next i
            r.Offset(1, 0).EntireRow.Delete
            LastRow = LastRow - 1
        End If
        ' Move to next row
        Set r = r.Offset(1, 0)
    Loop
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
End Sub

根据数据的总量，将所有数据加载到内存中并使用VBA数组处理它只会最终返回到工作表中会更快。

以下代码应该快几个数量级。

Sub DW2()

    Dim i As Long, j As Long, i_out As Long, i_next As Long

    Dim LastRow As Long, ValCol As Long, LastCol As Long
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    ValCol = Cells(, "L").Column
    LastCol = Cells(, "Q").Column

    Dim r_data As Range
    ' Reference all the data (filled rows, and 17 columns "A:Q")
    Set r_data = Range("A1").Resize(LastRow, LastCol)

    ' x is input data, y as output data
    Dim x() As Variant, y() As Variant

    ' Copy all the table cells into memory
    x = r_data.Value

    ' Create an empty array at least the same size
    ReDim y(1 To LastRow, 1 To LastCol)
    ' i_out is index for output
    i_out = 1
    ' i is index for input
    For i = 1 To LastRow
        ' Debug.Print "Row"; i, "into Row:"; i_out
        'Copy all values first from current row
        For j = 1 To LastCol
            y(i_out, j) = x(i, j)
        Next j
        ' Index i_next peeks at the next row
        i_next = i + 1
        If i_next >= LastRow Then
            ' Advance i_out
            i_out = i_out + 1
            Exit For
        End If
        ' Check with value match on 2nd column "B"
        Do While x(i, 2) = x(i_next, 2)
            'Add up values in columns 11 through 17
            For j = ValCol To LastCol
                y(i_out, j) = y(i_out, j) + x(i_next, j)
            Next j
            ' Peek at subsequent rows also
            i_next = i_next + 1
            If i_next >= LastRow Then
            ' Advance i_out
                i_out = i_out + 1
                Exit For
            End If
        Loop
        ' Advance i if rows were skipped
        i = i_next - 1
        ' Advance i_out
        i_out = i_out + 1
    Next i

    ' Clear all table cells
    r_data.ClearContents
    ' Overwrite with the optimized values
    r_data.Resize(i_out - 1, LastCol).Value = y
End Sub

_{编辑：现在测试数据末尾存在匹配行时的稳健性}

慢速VBA代码优化

2 个答案: