遍历不同文件中的命名范围并在VBA Excel中创建jpg

Question

我试图遍历VBA Excel中的命名范围，以便从我在特定单元格中创建的表中创建jpg / pics。 该代码不仅可以在一个工作簿中循环命名区域，还可以在“主” Excel工作表中按路径定义的多个工作簿中循环。

我已经在各个工作簿中分别命名了各个范围，以便它们出现在Excel的名称管理器中。

Public Sub Charts_to_JPG()

    '''''''''''''''''''
    '''Deklarationen'''
    '''''''''''''''''''

    Dim i As Integer
    Dim j As Integer
    Dim lastRowFiles As Integer

    Dim lWidth As Long, lHeight As Long

    Dim wb As Workbook
    Dim sht As Worksheet
    Dim nm As Name
    Dim rng As Range

    Dim chrt As ChartObject
    Dim objChrt As Chart

    Dim strFile As String
    Dim Filename As String

    ' Einige optische Feinheiten
    With Application
        .Cursor = xlWait
        .DisplayStatusBar = True
        .StatusBar = "Update der Excel-Dateien wird ausgeführt ..."
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        .AskToUpdateLinks = False
        .Calculation = xlCalculationManual
        .AutomationSecurity = msoAutomationSecurityForceDisable
    End With

    '''Erst mal alle anderen Workbooks schließen
    For Each wb In Workbooks
        If Not wb.Name = ThisWorkbook.Name Then
            wb.Close SaveChanges:=True
        End If
    Next wb

    lastRowFiles = CInt(WorksheetFunction.CountA(Worksheets("Main").Range("B6:B100000")))

    For i = 1 To lastRowFiles

        Workbooks.Open CStr(ThisWorkbook.Sheets("Main").Cells(5 + i, 2).Value)
        DoEvents
        Set wb = ActiveWorkbook

        Filename = CStr(CreateObject("Scripting.FileSystemObject").GetBaseName(wb.Name))


            For j = 1 To wb.Names.Count

                 Select Case CInt(wb.Names.Count)

                    Case 0

                        Exit For

                    Case Else

                     If Replace(CStr(wb.Names(j).RefersTo), "=", "") = "#NAME?" Then

                     Else

                         Set sht = Sheets(wb.Names(j).Application.ActiveSheet.Name)

                         Set rng = sht.Range(Replace(CStr(wb.Names(j).RefersTo), "=", ""))

                             rng.CopyPicture xlScreen, xlPicture
                             lWidth = rng.Width
                             lHeight = rng.Height

                             Set chrt = sht.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)

                             strFile = CStr(ThisWorkbook.Sheets("Main").Cells(5 + i, 4).Value) & "\" & Filename & "_" & CStr(wb.Names(j).Name) & ".jpg"

                             chrt.Activate
                             With chrt.Chart
                                  .Paste
                                  .Export strFile, FilterName:="JPG"
                             End With
                             DoEvents

                             chrt.Delete

                     End If

                End Select


            Next j

            wb.Close True

    Next i

    With Application
        .StatusBar = ""
        .DisplayStatusBar = False
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        .AskToUpdateLinks = True
        .Cursor = xlDefault
        .AutomationSecurity = msoAutomationSecurityLow
    End With 

End Sub

问题是我收到运行时错误'1004'，其Set rng = sht.Range(Replace(CStr(wb.Names(j).RefersTo), "=", ""))说' 方法范围失败对于特定代码行中的对象工作表 '。

任何想法如何解决此问题或以不同的方式编写它？ 任何帮助将不胜感激，因为我再也看不到树木的森林了。 提前非常感谢您！

Answer 1

好。 我终于弄清楚了，问题出在哪里。 该工作表对象已创建错误，因为Excel使用所有命名范围，包括所谓的“不可见”范围，这意味着旧的已删除范围。 您只需要添加一段代码即可，即If nm.visible = True Then等。这样，仅考虑在名称管理器中实际定义的可见命名范围。