Excel宏导出报表：移除旧工作簿引用并将图表转为图片

需要通过自制Excel工具生成移除数据引用的报表，将图表转为图片，但遇到图表处理难题：

• 已实现按钮触发宏导出「Report」和「Raw_Data」工作表，但宏会生成两个独立文件
• 已完成单元格值粘贴以移除原工作簿引用，但图表仍关联原工作簿，无法在同一宏内将图表转为图片替换原图表
• 卡点：不知如何选中图表并替换为图片

Sub ExportWorksheets()

    Dim worksheet_list As Variant, worksheet_name As Variant
    Dim new_workbook As Workbook
    Dim saved_folder As String
    
    worksheet_list = Array("Report", "Raw_Data")
    '// makes sure you close the path with a back slash
    saved_folder = "(I'm redacting this filepath for proprietary reasons)\"
    
    For Each worksheet_name In worksheet_list
    
        On Error Resume Next
        ' Opens a new Excel workbook
        Set new_workbook = Workbooks.Add
        
        ThisWorkbook.Worksheets(worksheet_name).Copy new_workbook.Worksheets(1)
        
        new_workbook.SaveAs saved_folder & worksheet_name & ".xlsx", 51
        
'        new_workbook.Close False
        
    Next worksheet_name
    
'This is the point where it kept messing up, originally.

Dim wbBook1 As Workbook
Dim wbBook2 As Workbook
Dim wbBook3 As Workbook

Set wbBook1 = ThisWorkbook
Set wbBook2 = Workbooks.Open("(I'm redacting this filepath for proprietary reasons but it's the filepath to the excel report that gets generated)")
Set wbBook3 = Workbooks.Open("(I'm redacting this filepath for proprietary reasons but it's the filepath to the excel report that gets generated)")

Dim wsSheet1 As Worksheet
Dim wsSheet2 As Worksheet
Dim wsSheet3 As Worksheet

Set wsSheet2 = wbBook2.Worksheets("Report")
Set wsSheet3 = wbBook3.Worksheets("Raw_Data")
    
   With wsSheet2.UsedRange
        .Copy
        .PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    End With

    With wsSheet3.UsedRange
        .Copy
        .PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    End With

'This is the point where, presumably, I would be able to cut and paste all charts on the worksheets 
'(wbBook2&3, first page of each) and replace them with images. 
'There are only 2... but idk how to select them.

    wbBook2.Save
    wbBook3.Save

    MsgBox "Export complete.", vbInformation

End Sub

修改宏逻辑，在复制工作表到新工作簿后直接处理值粘贴和图表转图片，无需重新打开文件，同时实现图表替换：

Sub ExportWorksheets()
    Dim worksheet_list As Variant, worksheet_name As Variant
    Dim new_workbook As Workbook
    Dim saved_folder As String
    Dim target_ws As Worksheet
    Dim chtObj As ChartObject
    Dim pic As Picture
    Dim i As Integer
    
    worksheet_list = Array("Report", "Raw_Data")
    saved_folder = "(替换为你的保存路径)\" ' 确保路径以反斜杠结尾
    
    ' 关闭屏幕更新提升运行效率
    Application.ScreenUpdating = False
    
    For Each worksheet_name In worksheet_list
        ' 创建仅含一个工作表的新工作簿，避免默认多余工作表
        Set new_workbook = Workbooks.Add(xlWBATWorksheet)
        ' 复制目标工作表到新工作簿
        ThisWorkbook.Worksheets(worksheet_name).Copy Before:=new_workbook.Worksheets(1)
        ' 删除新工作簿默认的空工作表
        Application.DisplayAlerts = False
        new_workbook.Worksheets(2).Delete
        Application.DisplayAlerts = True
        
        Set target_ws = new_workbook.Worksheets(1)
        
        ' 1. 粘贴单元格值，彻底移除原数据引用
        With target_ws.UsedRange
            .Copy
            .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Application.CutCopyMode = False
        End With
        
        ' 2. 将所有嵌入式图表转为图片并替换原图表
        ' 倒序遍历，避免删除图表后索引错乱
        For i = target_ws.ChartObjects.Count To 1 Step -1
            Set chtObj = target_ws.ChartObjects(i)
            
            ' 复制图表为图片格式
            chtObj.Chart.CopyPicture Appearance:=xlScreen, Format:=xlPicture
            ' 在原图表位置粘贴图片
            Set pic = target_ws.Pictures.Paste
            ' 保持图片与原图表的位置、大小完全一致
            With pic
                .Top = chtObj.Top
                .Left = chtObj.Left
                .Width = chtObj.Width
                .Height = chtObj.Height
            End With
            
            ' 删除原图表，切断与原工作簿的关联
            chtObj.Delete
        Next i
        
        ' 保存并关闭工作簿
        new_workbook.SaveAs saved_folder & worksheet_name & ".xlsx", 51
        new_workbook.Close SaveChanges:=False
    Next worksheet_name
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    MsgBox "导出完成。", vbInformation
End Sub

关键说明 #

• 简化流程：直接在新工作簿创建后完成所有处理，无需后续重新打开生成的文件，减少出错概率
• 图表处理逻辑：
  • 用ChartObjects定位工作表中的嵌入式图表
  • 倒序遍历防止删除图表后索引错乱，确保所有图表都被处理
  • 粘贴图片时匹配原图表的位置和大小，保证报表布局不变
• 性能优化：关闭屏幕更新和警告提示，让宏运行更流畅

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