VBA 如何调整我的代码以加快循环过程？答案

【问题标题】：VBA How do I adjust my code to speed up the loop process?VBA 如何调整我的代码以加快循环过程？
【发布时间】：2022-01-13 15:45:33
【问题描述】：

我有一个工作表更改事件，当在 C、D 和 E 列中填充 3 个相邻单元格时，它会记录在不同的工作表中，其中包含日期以及已填写单元格的工作表。

然后将每次出现的日期数据汇总并绘制在日历上，基本上显示一年中的每一天发生了多少条目。

问题是，代码会在一年中的所有日子循环，这使得它非常慢，有没有办法进行调整，使其不会循环遍历所有内容或至少加快进程？

这是相关循环的代码：

With Sheets("Log")
    Set dfCell = dws.Cells(dws.Rows.Count, dCol) _
                    .End(xlUp).Offset(1)
    dfCell.Value = Format(Date, "mm/dd/yyyy")
    dfCell.Offset(, 1).Value = ActiveSheet.Name
    dfCell.Offset(, 2).Value = srAddress

    Dim arrDates As Range
    Dim LastRow As Long
    Dim DateRange As Long
    Dim RowCount As Long
    Dim ClmnAmnt As Long
    Dim ClmnDate() As Variant
    Dim AddrArr() As Variant
    Dim ClmnNmbr As Long
    Dim shtNames As Range
    Dim TypCount As Long
    Dim FrstLetter() As Variant
    Dim SheetIdent As String
    Dim lastAddrs As String

    For RowCount = 1 To 60
        Select Case RowCount
            Case 2, 7, 12, 17, 22, 27, 32, 37, 42, 47, 52, 57
            LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
            DateRange = WorksheetFunction.CountA(.Range("F" & RowCount & ":AJ" & RowCount))
                For TypCount = 1 To 3
                    SheetIdent = .Cells(RowCount + TypCount, 5).Value
                        For ClmnNmbr = 1 To DateRange
                        
                            ReDim AddrArr(DateRange)
                            AddrArr(ClmnNmbr) = .Cells(RowCount, ClmnNmbr + 5).Value
                            
                            Set arrDates = .Range("A60:A" & LastRow)
                            Set shtNames = .Range("B60:B" & LastRow)
                            
                            
                            ReDim FrstLetter(DateRange)
                            FrstLetter(ClmnNmbr) = Application.CountIfs(arrDates, AddrArr(ClmnNmbr), shtNames, SheetIdent)
                            
                            Worksheets("Log").Cells(TypCount + RowCount, ClmnNmbr + 5).Value = Application.Transpose(FrstLetter(ClmnNmbr))
                            
                            
                        Next ClmnNmbr
                    Next TypCount
            Case Else
        End Select
    Next RowCount

End With

【问题讨论】：

For RowCount = 2 To 57 Step 5，在你的循环之外设置LastRow
为了速度，您可以在宏运行时关闭Application.ScreenUpdating，在循环开始时设置为False，在循环结束时设置为True。此外，由于您正在更改工作表，因此您也可以使用Application.Calculation = xlCalculationManual 暂时禁用工作表重新计算。不要忘记将其设置回自动 (xlCalculationAutomatic)。这两件事应该会大大提高执行速度。
1) 循环内似乎有很多不受循环影响的代码。将所有内容移到循环之外。 2）使用变体数组技术：在开始时将数据复制到一个数组，循环遍历数组并随时修改它。将数组复制回末尾的范围 3) 小心避免事件级联 4) 您确定每次更改都需要运行所有这些代码吗？也许您可以根据更改的单元格或值来减少运行次数
执行@Toddleson 的所有建议非常有帮助。循环现在循环遍历工作表中的多个行，其中包含多个范围，这些范围在数组FrstLetter 中捕获，但即使我看到它如何像@chris neilsen 所说的那样极大地加快这个过程，我也不会开始知道如何将这一点一并表达到多个领域。

标签： excel vba loops

【解决方案1】：

将每个月视为 3 行 x 28/29/30/31 列的单独数组，然后您可以读取、更新计数和回写。

Option Explicit

Sub UpdateCounts()
    
    Const COL_LETTER = "E"
    
    Dim rngA As Range, rngB As Range, counts, t0 As Single: t0 = Timer
    Dim LastRow As Long, LastCol As Long, dates, letters
    Dim i As Long, j As Long, d As Long, m As Long, r As Long
    
    With Sheets("Log")
    
        ' fill data
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set rngA = .Range("A60:A" & LastRow)
        Set rngB = .Range("B60:B" & LastRow)
       
        ' scan down sheet rows 2 to 57
        For m = 1 To 12 ' jan to dec
            r = 2 + (m - 1) * 5
            LastCol = .Cells(r, "AK").End(xlToLeft).Column
            d = LastCol - 5 ' no of days
            
            If d >= 28 And d <= 31 Then
            
                dates = .Cells(r, "F").Resize(, d).Value
                letters = .Cells(r + 1, "E").Resize(3).Value
                counts = .Cells(r + 1, "F").Resize(3, d).Value
                
                For j = 1 To d ' days
                
                    For i = 1 To 3
                        ' update counts
                        counts(i, j) = Application.CountIfs(rngA, dates(1, j), rngB, letters(i, 1))
                    Next
                  
                    ' update table
                    .Cells(r + 1, "F").Resize(3, d) = counts
                Next
            Else
                'Debug.Print r, "No table for month " & m
            End If
        Next
        
    End With
    MsgBox "Done in " & Format(Timer - t0, "0.0 s")
End Sub

【讨论】：