excel - VBA 有条件地将工作表导出为 pdf 文件（循环下拉列表和工作表）

Question

每个月我都有一个仪表板，需要为下拉列表中提供的每个人创建一个 pdf。我创建了一个循环遍历该下拉列表并为每个人创建一个 pdf 的代码。我的一位老板要求我根据他们是否满足特定条件向该 pdf 添加页面。我在不同的工作表上创建了该页面的一个版本，我希望循环遍历下拉列表中的每个人，但如果其他工作表满足附加该工作表的条件，也将它们附加到同一 pdf 的末尾。

这是该excel表的简化版本

所以VBA应该循环遍历下拉列表，检查底部的条件是否满足，并打印原始工作表和满足条件的工作表。

我通过页面布局在所有工作表中设置了一个打印区域，只要它打印工作表，它就应该捕获该打印区域，至少到目前为止它一直在这样做。

这是它循环遍历名称以在每次循环导出时重新加载原始工作表的选项卡，在命名约定中也使用第二列

VBA代码：

Sub VenA()
  c00 = "File Path" 'Just change the path
  ar = Sheets("People").ListObjects(1).DataBodyRange
  lm = Format(DateAdd("m", -1, Date), "yyyymm")
  With Sheets("Original")
    For j = 1 To UBound(ar)
      .Range("E3") = ar(j, 1)
      .ExportAsFixedFormat 0, c00 & "Report_" & lm & "_" & ar(j, 2) & ".pdf"
    Next j
  End With
End Sub

因此，我需要添加到该循环中，以便每次检查原始工作表中的范围，如果条件为是，则将相应的工作表附加到导出的 pdf 中。

先感谢您。

标签： excelvbaloops

Answer 1

编辑

工作代码

我将把坏代码留在底部。我最终不得不使用用该代码编写的概念并重写它们。这是我最终得到的代码。如果希望这可以帮助某人。

'***********************************************************************
' Purpose: Conditionally export sheets that meet criteria as single PDF  
'***********************************************************************

Sub SheetsAsPDF()

Const cESheets As String = "Sheet1,Sheet2,Sheet3,Sheet4,Sheet5"                  ' Sheet List
Const cSheet As String = "Dashboard"                                            ' Source Worksheet
Const cRange As String = "B105:B108"                                            ' Source Range Address
Const cCrit As Long = 1                                                         ' Criteria

Const c00 As String = "J:\g"    ' File Path

Dim dwb As Workbook    ' Export Workbook
Dim sws As Worksheet   ' Export Worksheet
Dim Cell As Range      ' Current Cell Range (For Each Control Variable)
Dim vntS() As String   ' Sheet Array
Dim j As Long          ' Range Array Element (Row) Counter
Dim i As Long          ' Range Array Element (Row) Counter
Dim iFound As Long     ' Target Element (Row) Counter

ar = Sheets("People").ListObjects(1).DataBodyRange                           ' Get Names
gs = Sheets("Dashboard").ListObjects(1).DataBodyRange                           ' Get Sheets
lm = Format(DateAdd("m", -1, Date), "yyyymm")                                   ' Last Month
vntS = Split(cESheets, ",") ' Copy (split) sheet names from Sheet List to 1D 0-based Sheet Array.

Set sws = ThisWorkbook.Worksheets(Trim(vntS(0)))


With Sheets("Dashboard")
  For j = 1 To UBound(ar)
  .Range("G7") = ar(j, 1)
    For Each Cell In sws.Range(cRange).Cells
        If Cell.Value = cCrit Then
            iFound = 1
            Exit For
        End If
    Next Cell
    If iFound = 0 Then Exit Sub

    

    ' **********************************
    ' Copy Sheets to New Workbook
    ' **********************************

    Application.ScreenUpdating = False

    sws.Copy
    Set dwb = ActiveWorkbook
    iFound = 0
    
    For Each Cell In sws.Range(cRange).Cells
        iFound = iFound + 1
        If Cell.Value = cCrit Then
            sws.Parent.Worksheets(Trim(vntS(iFound))).Copy _
                After:=dwb.Sheets(dwb.Sheets.Count)
        End If
    Next

    ' **********************************
    ' Export New Workbook to PDF
    ' **********************************

    With dwb
        .ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=c00 & "RVU_Bonus_Report_" & lm & "_" & ar(j, 2) & ".pdf", _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, OpenAfterPublish:=False
        .Close False
    End With

    Application.ScreenUpdating = True

    
  Next j
End With

End Sub
'********************************************************

失败的代码

这就是我到目前为止所拥有的。它仍然无法正常工作，但非常接近。它只会打印出适用于第一个人的工作表，在第一个循环之后会出现错误消息。它还将导出每个人，但无论条件如何，它都会打印出所有工作表（我在下面解释了我所做的）。当我有一个完整的解决方案时，我将编辑和修复代码以帮助任何有类似问题的人。

Sub SheetsAsPDF()

Const cSheets As String = "Dashboard,Ed165,Ed125,Ed130,Ed122" ' Sheet List
Const cSheet As String = "Dashboard"                   ' Source Worksheet
Const cRange As String = "B104:B108"                    ' Source Range Address
Const cCrit As Long = 1                             ' Criteria


Dim wb As Workbook    ' Export Workbook
Dim Cell As Range     ' Current Cell Range (For Each Control Variable)
Dim vntS As Variant   ' Sheet Array
Dim vntR As Variant   ' Range Array
Dim i As Long         ' Range Array Element (Row) Counter
Dim iTarget As Long   ' Target Element (Row) Counter
c00 = "J:\GenericFilePath" 'Just change the path
ar = Sheets("People").ListObjects(1).DataBodyRange
lm = Format(DateAdd("m", -1, Date), "yyyymm")

' **********************************
' Copy Sheets to New workbook.
' **********************************

' Reset Target Counter.
iTarget = -1

' Copy (split) sheet names from Sheet List to 1D 0-based Sheet Array.
vntS = Split(cSheets, ",")

' Copy Source Range in Source Worksheet to 2D 1-based 1-column Range Array.
vntR = ThisWorkbook.Worksheets(cSheet).Range(cRange)
' Loop through elements (rows) of Range Array (in its first (only) column).
' Note: Not obvious, one might say that the elements (rows) of Sheet Array
' are 'also being looped', but the counter is by 1 less.
With Sheets("Dashboard")
  For j = 1 To UBound(ar)
  .Range("E3") = ar(j, 1)
    For i = 1 To UBound(vntR)
        ' Check if current value in Range Array (vntR) is equal to Criteria
        ' (cCrit). Range Array is 2D (,1).
        If vntR(i, 1) = cCrit Then  ' Current value is equal to Criteria.
            ' Counter (add 1 to) Target Counter (iTarget).
            iTarget = iTarget + 1
            ' Write value of current element (row) of Sheet Array to the
            ' 'iTarget-th' element (row). Note: Values are being overwritten.
            ' Remarks
              ' Sheet Array is a zero-based array i.e. the index number of its
              ' first element is 0, NOT 1. Therefore i - 1 has to be used,
              ' which was previously indicated with 'also being looped'.
              ' Trim is used to avoid mistakes if the Sheet Name List is not
              ' properly written e.g. "Sheet1, Sheet2,Sheet3,  Sheet4".
            vntS(iTarget) = Trim(vntS(i - 1))
          'Else                      ' Current value is NOT equal to Criteria.
        End If
    Next ' Element (row) of Range Array (vntR).
    ' Check if there were any values that were equal to Criteria (cCrit) i.e.
    ' if there are any worksheets to export.
    If iTarget = -1 Then Exit Sub
    ' Resize Sheet Array to the value (number) of Target Counter (iTarget).
    ReDim Preserve vntS(iTarget) ' Note: Values are being deleted.
    ' Copy sheets of Sheet Array to New Workbook.
    ' Remarks
      ' When Copy (for copying sheets) is used without arguments, it will copy
      ' a sheet (array) to a NEW workbook.
    ThisWorkbook.Sheets(vntS).Copy

    ' **********************************
    ' Export New Workbook to PDF
    ' **********************************

    ' Create a reference (wb) to New Workbook which became the ActiveWorkbook
    ' after it had previously been 'created' using the Copy method.
    Set wb = ActiveWorkbook
    ' In New Workbook
    With wb
        ' Export New Workbook to PDF.
        wb.ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=c00 & "RVU_Bonus_Report_" & lm & "_" & ar(j, 2) & ".pdf", _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, OpenAfterPublish:=False
        ' Close New Workbook. False suppresses the message that asks for
        ' saving it.
        wb.Close False
        ' Remarks:
        ' Change this if you might want to save this version of New Workbook
        ' e.g.
        'wb.SaveAs "WB" & Format(Date, "yyyymmdd") & ".xls"
    End With
    
  Next j
End With
End Sub

到目前为止，这就是我最终得到的结果，while 和第一个 for 循环遍历下拉列表。第二个循环遍历每个单元格以查找 1 或 0，如果 1 将它们保存到新文件，第三个循环循环打开该保存的文件并将其导出为 PDF。

现在我遇到的唯一问题是，当它循环回到顶部时，我得到一个运行时错误'9'：下标超出范围。完美导出第一人称，只导出符合条件的工作表。它的在线中断....

vntS(iTarget) = Trim(vntS(i - 1))

我假设它正在中断，因为 i 或 iTarget 没有重置，并且它的数字已经超出了循环。我尝试将 iTarget = 1 添加到 end 和 next J 之前，这确实会循环遍历所有人，但会为所有人打印所有 5 个工作表，并且不会根据条件按 4 个工作表的条件过滤它们。

原始代码： Excel VBA 将基于单元格值的特定工作表导出为 PDF