VBA代码填充数组遇内存不足报错，公式无法正常生效求助

问题描述 #

编写的VBA代码用于从多个年份工作表中按星期几计算两列数据的平均值，运行时在.Cells(iRow, iCol).Resize(UBound(a, 1), UBound(a, 2)).Formula = a行触发Out of Memory错误。修改数组声明后内存问题解决，但原本应执行的公式变成了纯字符串，无法进行计算。

原代码如下：

Sub Calculate_Averages()
    Dim e, ws As Worksheet, iYear As Integer, iRow As Integer, iCol As Integer, i As Integer, lr As Long
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
        With ThisWorkbook.Worksheets("Adverage")
            .UsedRange.Cells.Clear
            iCol = 2: iRow = 4
            For iYear = 2022 To 2018 Step -1
                ReDim a(1 To 10, 1 To 3) As String
                Set ws = ThisWorkbook.Worksheets(CStr(iYear))
                lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
                If Not ws Is Nothing Then
                    a(1, 2) = ws.Name: a(1, 3) = ws.Name
                    a(2, 2) = "User 1": a(2, 3) = "User 2"
                    i = 0
                    For Each e In Array("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday")
                        i = i + 1
                        a(i + 2, 1) = e
                        a(i + 2, 2) = "=IFERROR(ROUND(AVERAGEIF('" & ws.Name & "'!$B$4:$B$" & lr & ",""" & e & """,'" & ws.Name & "'!$D$4:$D$" & lr & "),2),"""")"
                        a(i + 2, 3) = "=IFERROR(ROUND(AVERAGEIF('" & ws.Name & "'!$B$4:$B$" & lr & ",""" & e & """,'" & ws.Name & "'!$E$4:$E$" & lr & "),2),"""")"
                    Next e
                End If
                .Cells(iRow, iCol).Resize(UBound(a, 1), UBound(a, 2)).Formula = a
                iCol = iCol + 4
            Next iYear
        End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

原因分析 #

1. 内存溢出：原代码使用String类型数组存储公式字符串，一次性将整个数组写入单元格区域时，Excel解析大量公式字符串会占用过高内存，触发溢出错误。
2. 公式变字符串：若将数组改为Variant类型，直接赋值.Value会让Excel把带等号的字符串识别为文本，而非可执行公式。

解决方案 #

方案1：拆分数组赋值，缓解内存压力

保留原String数组声明，将文本内容和公式内容拆分写入，减少单次操作的内存占用：

Sub Calculate_Averages()
    Dim e, ws As Worksheet, iYear As Integer, iRow As Integer, iCol As Integer, i As Integer, lr As Long
    Dim a(1 To 10, 1 To 3) As String
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    With ThisWorkbook.Worksheets("Adverage")
        .UsedRange.Cells.Clear
        iCol = 2: iRow = 4
        For iYear = 2022 To 2018 Step -1
            Set ws = ThisWorkbook.Worksheets(CStr(iYear))
            lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
            If Not ws Is Nothing Then
                ' 填充文本与公式字符串
                a(1, 2) = ws.Name: a(1, 3) = ws.Name
                a(2, 2) = "User 1": a(2, 3) = "User 2"
                i = 0
                For Each e In Array("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday")
                    i = i + 1
                    a(i + 2, 1) = e
                    a(i + 2, 2) = "=IFERROR(ROUND(AVERAGEIF('" & ws.Name & "'!$B$4:$B$" & lr & ",""" & e & """,'" & ws.Name & "'!$D$4:$D$" & lr & "),2),"""")"
                    a(i + 2, 3) = "=IFERROR(ROUND(AVERAGEIF('" & ws.Name & "'!$B$4:$B$" & lr & ",""" & e & """,'" & ws.Name & "'!$E$4:$E$" & lr & "),2),"""")"
                Next e
                
                ' 分区域写入：先写文本，再写公式
                .Cells(iRow, iCol).Resize(UBound(a, 1), 1).Value = Application.Index(a, 0, 1)
                .Cells(iRow, iCol + 1).Resize(2, 2).Value = Application.Index(a, 1 To 2, 2 To 3)
                .Cells(iRow + 2, iCol + 1).Resize(7, 2).Formula = Application.Index(a, 3 To 9, 2 To 3)
            End If
            iCol = iCol + 4
        Next iYear
    End With
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

方案2：使用Variant数组，强制识别公式

改用Variant数组，先写入所有内容，再对公式区域重新设置.Formula属性，强制Excel识别为可执行公式：

Sub Calculate_Averages()
    Dim e, ws As Worksheet, iYear As Integer, iRow As Integer, iCol As Integer, i As Integer, lr As Long
    Dim a(1 To 10, 1 To 3) As Variant
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    With ThisWorkbook.Worksheets("Adverage")
        .UsedRange.Cells.Clear
        iCol = 2: iRow = 4
        For iYear = 2022 To 2018 Step -1
            Set ws = ThisWorkbook.Worksheets(CStr(iYear))
            lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
            If Not ws Is Nothing Then
                a(1, 2) = ws.Name: a(1, 3) = ws.Name
                a(2, 2) = "User 1": a(2, 3) = "User 2"
                i = 0
                For Each e In Array("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday")
                    i = i + 1
                    a(i + 2, 1) = e
                    a(i + 2, 2) = "=IFERROR(ROUND(AVERAGEIF('" & ws.Name & "'!$B$4:$B$" & lr & ",""" & e & """,'" & ws.Name & "'!$D$4:$D$" & lr & "),2),"""")"
                    a(i + 2, 3) = "=IFERROR(ROUND(AVERAGEIF('" & ws.Name & "'!$B$4:$B$" & lr & ",""" & e & """,'" & ws.Name & "'!$E$4:$E$" & lr & "),2),"""")"
                Next e
                
                ' 先写入所有内容（此时公式为文本）
                .Cells(iRow, iCol).Resize(UBound(a, 1), UBound(a, 2)).Value = a
                ' 强制将公式区域识别为可执行公式
                .Cells(iRow + 2, iCol + 1).Resize(7, 2).Formula = .Cells(iRow + 2, iCol + 1).Resize(7, 2).Value
            End If
            iCol = iCol + 4
        Next iYear
    End With
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

关键提示 #

• 拆分赋值的核心是降低单次写入操作的内存负载，避免Excel因一次性解析大量公式字符串而溢出。
• 使用Variant数组时，二次设置.Formula属性是关键，这会让Excel重新解析单元格内容，将文本格式的公式转为可执行状态。

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