Excel VBA，通过范围加速 For 循环

Question

我有一个单页 Excel 文件，其中包含 105 列和 6,000 多行（并且还在增长）。

每一列代表一个资源，每一行是一个时间戳。

每个单元格包含一个 1（资源已满）或一个 0（资源空）

我需要计算一列从 1 变为 0 或 0 变为 1 的次数。

我目前正在使用两个循环来允许我按列循环遍历一个范围。

cLAST = Range("XFD2").End(xlToLeft).Column
rLAST = Range("B65536").End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlManual
    Set rng = Range("B5", Cells(rLAST, cLAST))
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
TimerStart = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    For lLoop = 1 To rng.Columns.Count
        TimerStart = Timer
        For Each i In rng.Columns(lLoop).Cells
            If Cells(3, i.Column).Value = 0 Then
                GoTo MidLoop
            End If
            If Len(i.Offset(1, 0).Value) > 0 Then
                If i.Value <> i.Offset(1, 0).Value Then
                    i.Value = "Pass"
                End If
            End If
MidLoop:
            If i.Row Mod 1000 = 0 Then
                Debug.Print i.Row, rLAST, i.Column, cLAST
            End If
    Next i
    TimerStop = Timer
    Debug.Print TimerStop - TimerStart
Next lLoop
objXL.Application.Calculation = xlAutomatic
objXL.Application.ScreenUpdating = True

每个列的循环整个过程大约需要 60 秒或大约 1 小时 45 分钟。

任何有关加快此过程的想法将不胜感激。

谢谢你， 凯文

Answer 1

这是基于您发布的代码（但忽略检查每列的第 3 行值，因为我不太清楚它打算做什么）：

Sub Tester()

    Dim lastCol As Long, lastRow As Long, numRows As Long, nxt
    Dim ws As Worksheet, data, colNum As Long, rowNum As Long
    Dim t, Rng As Range

    t = Timer
    
    Set ws = ActiveSheet 'or whatever
    lastCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    Set Rng = ws.Range("B5", ws.Cells(lastRow, lastCol))
    numRows = Rng.Rows.Count
    
    data = Rng.Value 'read the whole range
    
    For colNum = 1 To Rng.Columns.Count
        For rowNum = 1 To numRows - 1
            nxt = data(rowNum + 1, colNum)
            If Len(nxt) > 0 Then
                If nxt <> data(rowNum, colNum) Then
                    data(rowNum, colNum) = "Pass"
                End If
            End If
        Next rowNum
    Next colNum
    
    Rng.Value = data 'return the data
    
    Debug.Print "Done in " & (Timer - t) & " secs"
    
End Sub

这在大约一秒钟内处理了大约 6k 行 x 100 列的范围。