Excel VBA运行时错误7：内存不足问题及代码优化求助

我需要优化这段VBA宏代码，目前执行到Range("tab_eposter").Value = copyRange时出现内存不足错误，但这里只是把18×5的单元格区域存入Variant变量，操作的Excel文件也只有130KB和80KB，实在不应该出现内存问题，怀疑有未发现的内存泄漏。请帮忙排查并优化代码：

Option Explicit

Function GetRangeNames(ByRef wb As Workbook) As String
  Dim cmdSet As String
  Dim nm As Object
  For Each nm In wb.Names
    If nm.Name Like Chr(42) & "info_" & Chr(42) Or _
       nm.Name Like Chr(42) & "timer_" & Chr(42) Then
        cmdSet = cmdSet & "If RangeExists(""" & nm.Name & """) Then ActiveWorkbook.Names(""" & nm.Name & """).Delete" & vbCrLf
        cmdSet = cmdSet & "ActiveWorkbook.Names.Add Name:=""" & nm.Name & """, RefersTo:=""" & nm.RefersTo & """" & vbCrLf
    End If
  Next nm
  Set nm = Nothing
  GetRangeNames = cmdSet
End Function


Sub StringExecute(s As String)
    Dim vbComp As Object
    Set vbComp = ThisWorkbook.VBProject.VBComponents.Add(1)
    vbComp.CodeModule.AddFromString _
        "Function RangeExists(R As String) As Boolean" & vbCrLf _
        & "Dim Test As Range" & vbCrLf _
        & "On Error Resume Next" & vbCrLf _
        & "Set Test = ActiveSheet.Range(R)" & vbCrLf _
        & "RangeExists = Err.Number = 0" & vbCrLf _
        & "End Function" & vbCrLf _
        & "Sub foo()" & vbCrLf _
        & s & vbCrLf _
        & "End Sub"
    Application.Run vbComp.Name & ".foo"
    ThisWorkbook.VBProject.VBComponents.Remove vbComp
End Sub


Sub prosjekt_oppdateringer()

' ------------ INIT --------------
  Application.DisplayAlerts = False
  Application.CutCopyMode = False
  Dim namesCmdSet As String
  Dim copyRange As Variant


' ------------ UPDATE LEVERANSE-DATA TABLE --------------
  Sheets("leveranse-data").Select
  If Range("Z1").Value <> "Tid etter leverandør" Then
    Columns("Z:Z").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("tab_leveranse_data[[#Headers],[Kolonne1]]").Select
    ActiveCell.FormulaR1C1 = "OB"
    Columns("Z:Z").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("tab_leveranse_data[[#Headers],[Kolonne1]]").Select
    ActiveCell.FormulaR1C1 = "Tid etter leverandør"
    Application.CutCopyMode = False
  End If


' ------------ UPDATE EPOST TABLE --------------
  Sheets("prosjekt-info").Select
  Range("tab_eposter").Select

  Application.Workbooks.Open _
    Filename:="!prosjekt.xlsx", _
    Local:=True

  copyRange = Range("tab_eposter").Formula2Local
  namesCmdSet = GetRangeNames(ActiveWorkbook)

  Application.CutCopyMode = False
  ActiveWindow.Close False

  StringExecute (namesCmdSet)
  namesCmdSet = ""

  Range("tab_eposter").Value = copyRange ' <--- 出现内存不足错误的位置

  Sheets("prosjekt-info").Select
  Range("D3").Select



' ------------ DE-INIT --------------
'  ThisWorkbook.VBProject.VBE.MainWindow.Visible = False
  Application.CutCopyMode = False
'  Application.Quit

End Sub

优化方案 #

1. 移除冗余的Select/Selection操作 #

大量使用Select和Selection会额外占用内存且降低执行效率，直接操作单元格对象即可：

' 替换原UPDATE LEVERANSE-DATA TABLE段代码
Dim wsLeveranse As Worksheet
Set wsLeveranse = ThisWorkbook.Sheets("leveranse-data")
With wsLeveranse
    If .Range("Z1").Value <> "Tid etter leverandør" Then
        .Columns("Z:Z").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        .Range("tab_leveranse_data[[#Headers],[Kolonne1]]").FormulaR1C1 = "OB"
        .Columns("Z:Z").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        .Range("tab_leveranse_data[[#Headers],[Kolonne1]]").FormulaR1C1 = "Tid etter leverandør"
    End If
End With

2. 重构命名区域同步逻辑，避免动态生成代码 #

原代码通过动态创建VB组件执行字符串的方式极易引发内存泄漏，直接通过对象操作实现命名区域同步：

' 替换原GetRangeNames和StringExecute函数/过程
Sub SyncRangeNames(sourceWB As Workbook, targetWB As Workbook)
    Dim nm As Name
    Dim targetNm As Name
    ' 遍历源工作簿的命名区域
    For Each nm In sourceWB.Names
        If nm.Name Like "*info_*" Or nm.Name Like "*timer_*" Then
            ' 检查目标工作簿是否存在同名区域，存在则删除
            On Error Resume Next
            Set targetNm = targetWB.Names(nm.Name)
            On Error GoTo 0
            If Not targetNm Is Nothing Then
                targetWB.Names(nm.Name).Delete
            End If
            ' 添加新的命名区域
            targetWB.Names.Add Name:=nm.Name, RefersTo:=nm.RefersTo
            Set targetNm = Nothing
        End If
    Next nm
    Set nm = Nothing
End Sub

3. 优化对象与内存管理 #

• 显式指定工作簿/工作表对象，避免依赖ActiveWorkbook/ActiveSheet
• 操作完成后清空Variant变量、释放对象引用，减少内存占用

优化后的完整代码 #

Option Explicit

Sub SyncRangeNames(sourceWB As Workbook, targetWB As Workbook)
    Dim nm As Name
    Dim targetNm As Name
    For Each nm In sourceWB.Names
        If nm.Name Like "*info_*" Or nm.Name Like "*timer_*" Then
            On Error Resume Next
            Set targetNm = targetWB.Names(nm.Name)
            On Error GoTo 0
            If Not targetNm Is Nothing Then
                targetWB.Names(nm.Name).Delete
            End If
            targetWB.Names.Add Name:=nm.Name, RefersTo:=nm.RefersTo
            Set targetNm = Nothing
        End If
    Next nm
    Set nm = Nothing
End Sub

Sub prosjekt_oppdateringer()
    ' ------------ INIT --------------
    Application.DisplayAlerts = False
    Application.CutCopyMode = False
    Application.ScreenUpdating = False ' 关闭屏幕更新提升效率
    Dim copyRange As Variant
    Dim wsLeveranse As Worksheet, wsProjektInfo As Worksheet
    Dim sourceWB As Workbook
    
    Set wsLeveranse = ThisWorkbook.Sheets("leveranse-data")
    Set wsProjektInfo = ThisWorkbook.Sheets("prosjekt-info")

    ' ------------ UPDATE LEVERANSE-DATA TABLE --------------
    With wsLeveranse
        If .Range("Z1").Value <> "Tid etter leverandør" Then
            .Columns("Z:Z").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
            .Range("tab_leveranse_data[[#Headers],[Kolonne1]]").FormulaR1C1 = "OB"
            .Columns("Z:Z").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
            .Range("tab_leveranse_data[[#Headers],[Kolonne1]]").FormulaR1C1 = "Tid etter leverandør"
        End If
    End With

    ' ------------ UPDATE EPOST TABLE --------------
    Set sourceWB = Application.Workbooks.Open(Filename:="!prosjekt.xlsx", Local:=True)
    ' 读取源数据
    copyRange = sourceWB.Sheets("prosjekt-info").Range("tab_eposter").Formula2Local
    ' 同步命名区域
    SyncRangeNames sourceWB, ThisWorkbook
    
    ' 关闭源工作簿
    sourceWB.Close SaveChanges:=False
    Set sourceWB = Nothing

    ' 写入数据到目标区域
    wsProjektInfo.Range("tab_eposter").Value = copyRange
    ' 清空变量释放内存
    Erase copyRange

    ' ------------ DE-INIT --------------
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    ' 定位到指定单元格（可选）
    wsProjektInfo.Range("D3").Select
End Sub

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