VBA实现按配置表批量导出Excel指定工作表为PDF求助

核心实现逻辑：

• 启动时先读取宏文件内sheet_select_table1配置表的规则，建立文件名与目标导出工作表序号的映射关系
• 遍历文件时自动跳过宏文件自身，避免转换配置文件
• 文件名匹配配置规则时，仅导出指定序号的工作表；未匹配时默认导出文件内全部工作表
• 补全原代码缺失的错误捕获、全表导出逻辑，避免运行中断

Sub Convert_Excel_To_PDF()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String, Fnum As Long
    Dim mybook As Workbook
    Dim CalcMode As Long
    Dim sh As Worksheet
    Dim ErrorYes As Boolean
    Dim LPosition As Integer
    Dim configSht As Worksheet
    Dim configDict As Object
    Dim configStartRow As Long, configEndRow As Long
    Dim i As Long
    Dim targetSheetIndex As Integer
    Dim mybookname As String
    Dim exportPath As String
    
    ' -------------------------- 可修改配置项 --------------------------
    MyPath = "C:\downloads\example_test\" ' 待转换Excel文件所在文件夹
    exportPath = "C:\downloads\example_test\" ' PDF导出路径，可和源文件路径不同
    configStartRow = 2 ' 配置表规则起始行，默认第1行为表头从第2行开始读，无表头则改为1
    ' -----------------------------------------------------------------
    
    ' 初始化配置字典，读取sheet_select_table1的匹配规则
    Set configDict = CreateObject("Scripting.Dictionary")
    Set configSht = ThisWorkbook.Worksheets("sheet_select_table1")
    configEndRow = configSht.Cells(configSht.Rows.Count, "A").End(xlUp).Row
    For i = configStartRow To configEndRow
        If Trim(configSht.Cells(i, "A").Value) <> "" And IsNumeric(configSht.Cells(i, "B").Value) Then
            configDict(Trim(configSht.Cells(i, "A").Value)) = CInt(configSht.Cells(i, "B").Value)
        End If
    Next i
    
    ' 遍历获取待处理文件夹下所有Excel格式文件
    FilesInPath = Dir(MyPath & "*.xls*")
    If FilesInPath = "" Then
        MsgBox "未找到可转换的Excel文件"
        Exit Sub
    End If

    Fnum = 0
    Do While FilesInPath <> ""
        ' 跳过宏文件自身
        If FilesInPath <> ThisWorkbook.Name Then
            Fnum = Fnum + 1
            ReDim Preserve MyFiles(1 To Fnum)
            MyFiles(Fnum) = FilesInPath
        End If
        FilesInPath = Dir()
    Loop
    
    ' 关闭Excel界面更新、自动计算提升运行速度
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With

    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum), ReadOnly:=True)
            On Error GoTo 0

            If Not mybook Is Nothing Then
                LPosition = InStr(1, mybook.Name, ".") - 1
                mybookname = Left(mybook.Name, LPosition)
                
                On Error Resume Next
                ' 判断当前文件是否匹配配置规则
                If configDict.Exists(mybook.Name) Then
                    targetSheetIndex = configDict(mybook.Name)
                    ' 校验指定序号的工作表是否存在
                    If targetSheetIndex < 1 Or targetSheetIndex > mybook.Worksheets.Count Then
                        ErrorYes = True
                        mybook.Close SaveChanges:=False
                        GoTo NextFile
                    End If
                    ' 导出指定工作表
                    mybook.Worksheets(targetSheetIndex).ExportAsFixedFormat _
                        Type:=xlTypePDF, _
                        Filename:=exportPath & mybookname & ".pdf", _
                        Quality:=xlQualityStandard, _
                        IncludeDocProperties:=True, _
                        IgnorePrintAreas:=False, _
                        OpenAfterPublish:=False
                Else
                    ' 未匹配规则，导出全部工作表
                    mybook.ExportAsFixedFormat _
                        Type:=xlTypePDF, _
                        Filename:=exportPath & mybookname & ".pdf", _
                        Quality:=xlQualityStandard, _
                        IncludeDocProperties:=True, _
                        IgnorePrintAreas:=False, _
                        OpenAfterPublish:=False
                End If
                
                If Err.Number <> 0 Then
                    ErrorYes = True
                    Err.Clear
                End If
                On Error GoTo 0
            End If

            mybook.Close SaveChanges:=False
NextFile:
        Next Fnum
    End If

    ' 错误提示
    If ErrorYes = True Then
        MsgBox "部分文件处理失败，可能原因：" & vbNewLine & "工作簿/工作表受保护、配置指定的工作表序号不存在、文件被占用"
    End If

    ' 恢复Excel默认设置
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
        .DisplayAlerts = True
    End With
    
    ' 释放对象
    Set configDict = Nothing
    Set configSht = Nothing
    Set mybook = Nothing
End Sub

配置表要求 #

• 配置表名称必须为sheet_select_table1，存放在运行宏的macro_file.xlsm文件内
• A列填写完整待匹配文件名（必须带后缀，例如04-file1.xls、08-test2.xlsx）
• B列填写对应文件需要导出的工作表序号（数字格式，1代表工作簿内第一个工作表）

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