将复杂Excel公式转换为VBA以优化表格计算性能

• Excel表格因复杂公式计算卡顿：每次在Data工作表添加/编辑原始数据时，都会触发“Calculating 4 processors”提示且耗时极久
• Data工作表约18000条记录，目标状态提取工作表约8000条记录，需代码自动识别数据最后一行
• 原公式：

=IF(SUMPRODUCT((Data!$A$2:$A$17989=A7076)(Data!$B$2:$B$17989=B7076)(Data!$C$2:$C$17989="Combine")),"Available",IF(COUNTIFS(Data!$A$2:$A$17989,A7076,Data!$B$2:$B$17989,B7076,Data!$C$2:$C$17989,"Feed *")=2,"Available","Not Available"))

• 录制的宏代码未解决效率问题：

Sub Macro1()
'
ActiveCell.FormulaR1C1 = _
    "=IF(SUMPRODUCT((Data!R2C1:R17989C1=RC[-5])*(Data!R2C2:R17989C2=RC[-4])*(Data!R2C3:R17989C3=""Combine"")),""Available"",IF(COUNTIFS(Data!R2C1:R17989C1,RC[-5],Data!R2C2:R17989C2=RC[-4],Data!R2C3:R17989C3=""Feed *"")=2,""Available"",""Not Available""))"

Range("F2").Select

Selection.Copy

Range("F3:F7076").Select

ActiveSheet.Paste

Application.CutCopyMode = False

Selection.End(xlUp).Select

Range("F3").Select

ActiveWorkbook.Save
End Sub

• 需求：将原公式转换为高效VBA代码，解决卡顿问题

核心思路是一次性读取所有数据到内存数组，通过内存计算完成状态判断，避免重复调用工作表函数和反复读写单元格，大幅提升运行效率。

Sub UpdateAvailabilityStatus()
    Dim wsData As Worksheet, wsTarget As Worksheet
    Dim arrData As Variant, arrTarget As Variant, arrResult As Variant
    Dim lastRowData As Long, lastRowTarget As Long
    Dim i As Long, j As Long
    Dim hasCombine As Boolean, feedCount As Integer
    
    ' 关闭屏幕更新和自动计算，减少资源占用
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 定义工作表（请将"Status"替换为你的目标工作表名称）
    Set wsData = ThisWorkbook.Worksheets("Data")
    Set wsTarget = ThisWorkbook.Worksheets("Status")
    
    ' 获取Data表最后一行并读取数据到数组
    lastRowData = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
    arrData = wsData.Range("A2:C" & lastRowData).Value
    
    ' 获取目标表最后一行并读取匹配列数据到数组
    lastRowTarget = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
    arrTarget = wsTarget.Range("A2:B" & lastRowTarget).Value
    ReDim arrResult(1 To UBound(arrTarget, 1), 1 To 1) ' 初始化结果数组
    
    ' 遍历目标表每条记录，匹配Data表数据
    For i = 1 To UBound(arrTarget, 1)
        hasCombine = False
        feedCount = 0
        
        ' 遍历Data表进行匹配判断
        For j = 1 To UBound(arrData, 1)
            If arrData(j, 1) = arrTarget(i, 1) And arrData(j, 2) = arrTarget(i, 2) Then
                Select Case arrData(j, 3)
                    Case "Combine"
                        hasCombine = True
                    Case Like "Feed *"
                        feedCount = feedCount + 1
                End Select
            End If
        Next j
        
        ' 根据判断结果赋值
        arrResult(i, 1) = IIf(hasCombine Or feedCount = 2, "Available", "Not Available")
    Next i
    
    ' 将结果一次性写入目标表F列
    wsTarget.Range("F2:F" & lastRowTarget).Value = arrResult
    
    ' 恢复系统设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    ' 保存工作簿
    ThisWorkbook.Save
End Sub

可选优化：提前终止内层循环 #

如果希望进一步提升速度，可以在找到"Combine"或feedCount达到2时，直接跳出内层循环，减少不必要的遍历：

' 修改内层循环部分
For j = 1 To UBound(arrData, 1)
    If arrData(j, 1) = arrTarget(i, 1) And arrData(j, 2) = arrTarget(i, 2) Then
        Select Case arrData(j, 3)
            Case "Combine"
                hasCombine = True
                Exit For ' 找到Combine后直接结束内层循环
            Case Like "Feed *"
                feedCount = feedCount + 1
                If feedCount >= 2 Then Exit For ' 计数达标后结束内层循环
        End Select
    End If
Next j

内容的提问来源于stack exchange，提问作者Salman Shafi