有什么好的方法可以加快这个 VBA 代码的速度吗？

Question

我必须运行在大约 5000 多行的 sheet 上编写此代码。在这一点上，我可以手动更快地完成它。我需要添加一个新行，从上一行中保留一些值，创建小计，并在第 'G' 列发生变化的任何地方重新着色。此代码将从第 8 行开始，只需要应用于单元格 E:X。有更好的方法吗？

在进一步测试中，问题似乎是我必须单独添加数百行。有没有办法找到所有值不等于上面的行并将所有行一起添加？

Sub subtotals()

'counter variables
cs = 8
c = 8


Do Until Range("E" & r) = ""


c = r
cs = r

'Do until Material Column does not equal material above
Do Until Range("g" & r) <> Range("g" & r + 1)
c = c + 1
r = r + 1
Loop

r = r + 1

Rows(r).Insert

'total label in SECTION
x = "e"
Range(x & r) = "Total"

x = "q"
Range(x & r).Formula = "=sum(" & x & cs & ":" & x & c & ")"

'rows to shade
Range("E" & r, "x" & r).Locked = True
Range("E" & r, "x" & r).Select

'shading
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark2
.TintAndShade = -0.499984740745262
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.Bold = True
End With
Selection.HorizontalAlignment = xlCenter

r = r + 1

Loop
End Sub

Answer 1

插入小计

最多一千个插入的行这将起作用，即需要几秒钟。在那之后，可能需要永远。
尝试在您的代码中实现 Application.Calculation 和 Application.ScreenUpdating。它的用法非常简单。它会加速你的代码。

Option Explicit

Sub InsertSubtotals()
    
    Const wsName As String = "Sheet1" ' adjust
    Const fRow As Long = 8 ' First Row
    Const tCol As String = "E" ' Total Column
    Const cCol As String = "G" ' Criteria (Search) Column
    Const fCol As String = "Q" ' Formula Column
    Const fCols As String = "E:X" ' Format Columns
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code

    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, tCol).End(xlUp).Row
    If lRow < fRow Then Exit Sub ' no data

    Dim pRow As Long: pRow = lRow + 1

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim trg As Range ' Total Range
    Dim OldValue As Variant
    Dim NewValue As Variant
    Dim r As Long
    Dim pFormula As String
    
    For r = pRow To fRow + 1 Step -1
        NewValue = ws.Cells(r - 1, cCol).Value
        If StrComp(CStr(NewValue), CStr(OldValue), vbTextCompare) <> 0 Then
            If pRow > r Then
                WriteFormula ws, r, pRow, fCol
                pRow = r
            End If
            ws.Rows(r).Insert
            If Not trg Is Nothing Then
                Set trg = Union(trg, ws.Cells(r, tCol))
            Else
                Set trg = ws.Cells(r, tCol)
            End If
            OldValue = NewValue
        End If
    Next r
    WriteFormula ws, fRow, pRow, fCol
     
    ' Write 'Total' in one go.
    trg.Value = "Total"
    
    ' Apply formatting in one go.
    With Intersect(trg.EntireRow, ws.Columns(fCols))
        .Locked = True
        With .Interior
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark2
            .TintAndShade = -0.499984740745262
            .PatternTintAndShade = 0
        End With
        With .Font
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
            .Bold = True
        End With
        .HorizontalAlignment = xlCenter
    End With

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

Sub WriteFormula( _
        ByVal ws As Worksheet, _
        ByVal r As Long, _
        ByVal pRow As Long, _
        ByVal ColumnString As String)
    Dim pFormula As String
    pFormula = "=SUM(" & ColumnString & r & ":" & ColumnString & pRow - 1 & ")"
    ws.Cells(pRow, ColumnString).Formula = pFormula
End Sub

有什么好的方法可以加快这个 VBA 代码的速度吗？

Is there a good way to speed up this VBA code?

excel

optimization

vba

插入小计