有沒有加速這個VBA代碼的好方法？

我必須在大約 5000 多行的作業表上運行此代碼。在這一點上，我可以手動更快地完成。我需要添加一個新行，從前一行中洗掉一些值，創建小計，并在“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

uj5u.com熱心網友回復：

插入小計

• 多達一千個插入的行這會起作用，即它需要幾秒鐘。在那之后，它可能需要永遠。
• 嘗試實作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 优化

上一篇：使用PowerShell歸檔沒有一些子檔案夾和檔案的檔案夾

下一篇：如果行相等，則VBA平均值