将 Excel 工作簿中的所有图表导出到 windows 文件夹

Question

我尝试运行以下宏。似乎可以工作（我没有任何错误），但最后只打开一个空文件夹（没有导出图片）。请给我任何建议！我是VBA的初学者。非常感谢！

Sub ExportAllCharts()
    Dim objShell As Object
    Dim objWindowsFolder As Object
    Dim strWindowsFolder As String
    Dim objSheet As Excel.Worksheet
    Dim objChartObject As Excel.ChartObject
    Dim objChart As Excel.Chart

    'Select a Windows folder
    Set objShell = CreateObject("Shell.Application")
    Set objWindowsFolder = objShell.BrowseForFolder(0, "Select a Windows folder:", 0, "")

    If Not objWindowsFolder Is Nothing Then
       strWindowsFolder = objWindowsFolder.self.Path & "\"

       For i = ThisWorkbook.Worksheets.Count To 1 Step -1
           Set objSheet = ThisWorkbook.Worksheets(i)

           If objSheet.ChartObjects.Count > 0 Then
              For Each objChartObject In objSheet.ChartObjects
                  Set objChart = objChartObject.Chart
                  objChart.Export strWindowsFolder & objChart.Name & ".png"
              Next
          End If
       Next

       'Open the windows folder
       Shell "Explorer.exe" & " " & strWindowsFolder, vbNormalFocus
   End If
End Sub

Source code link

现在我正在尝试找到一种解决方案来导出所有具有工作表名称+后缀的图表。 我希望我可以在弹出窗口中插入所需的后缀（所有工作表都相同）。

我有这段代码重命名所有工作表，但我需要修改它以仅重命名它们部分。我想也许我可以将它合并到初始宏中。

Sub ChangeWorkSheetName()
Dim Rng As Range
Dim WorkRng As Range
On Error Resume Next
xTitleId = "Write the new Worksheets Name"
NewName = Application.InputBox("Name", xTitleId, "", Type:=2)
j = 1
For i = 1 To Application.Sheets.Count
If Application.Sheets(i).Visible Then
Application.Sheets(i).Name = NewName & j
j = j + 1
End If
Next
End Sub

谁能给我一个建议？非常感谢！

Answer 1

如果您需要在图表表中包含图表，则需要第二个循环：

Sub ExportAllCharts()
    Dim objShell As Object
    Dim objWindowsFolder As Object
    Dim strWindowsFolder As String
    Dim objSheet As Excel.Worksheet
    Dim objChartObject As Excel.ChartObject
    Dim objChart As Excel.Chart
    
    'Select a Windows folder
    Set objShell = CreateObject("Shell.Application")
    Set objWindowsFolder = objShell.BrowseForFolder(0, "Select a Windows folder:", 0, "")
    
    If Not objWindowsFolder Is Nothing Then
        strWindowsFolder = objWindowsFolder.self.Path & "\"
        
        'charts on chart sheets
        For Each objChart In ThisWorkbook.Charts
            objChart.Export strWindowsFolder & objChart.Name & ".png"
        Next objChart
        
        'chartobjects (on worksheets)
        For Each objSheet In ThisWorkbook.Worksheets
            For Each objChartObject In objSheet.ChartObjects
                With objChartObject.Chart
                    .Export strWindowsFolder & .Name & ".png"
                End With
            Next
        Next
        
        'Open the windows folder
        Shell "Explorer.exe" & " " & strWindowsFolder, vbNormalFocus
    End If
End Sub