如何使用VBA以定义的顺序遍历工作表

我有下面的工作代码循环通过每个工作表，如果在范围（myrange）中定义的值是'Y'，它将这些工作表输出到一个PDF文档。 我的挑战是，我想根据范围内的数值（例如1,2,3,4,5,6,7等）来定义它们在PDF中输出的顺序，而不是“Y”。 我打算使用myrange中的相同列来检查是否需要输出为PDF，只需将“Y”replace为数字，如“1”和“2”。

目前，订单是根据工作表选项卡的位置定义的。 从左到右。

任何帮助都感激不尽。

Sub Run_Me_To_Create_Save_PDF() Dim saveAsName As String Dim WhereTo As String Dim sFileName As String Dim ws As Worksheet Dim printOrder As Variant '**added** Dim myrange On Error GoTo Errhandler Sheets("Settings").Activate ' Retrieve value of 'Period Header' from Settings sheet Range("C4").Activate periodName = ActiveCell.Value ' Retrieve value of 'File Name' from Settings sheet Range("C5").Activate saveAsName = ActiveCell.Value ' Retrieve value of 'Publish PDF to Folder' from Settings sheet Range("C6").Activate WhereTo = ActiveCell.Value Set myrange = Worksheets("Settings").Range("range_sheetProperties") ' Check if Stamp-field has any value at all and if not, add the current date. If Stamp = "" Then Stamp = Date ' Assemble the filename sFileName = WhereTo & saveAsName & " (" & Format(CDate(Date), "DD-MMM-YYYY") & ").pdf" ' Check whether worksheet should be output in PDF, if not hide the sheet For Each ws In ActiveWorkbook.Worksheets Sheets(ws.Name).Visible = True printOrder = Application.VLookup(ws.Name, myrange, 4, False) If Not IsError(printOrder) Then If printOrder = "Y" Then Sheets(ws.Name).Visible = True End If Else: Sheets(ws.Name).Visible = False End If Next 'Save the File as PDF ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ sFileName, Quality _ :=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _ OpenAfterPublish:=True ' Unhide and open the Settings sheet before exiting Sheets("Settings").Visible = True Sheets("Settings").Activate MsgBox "PDF document has been created and saved to : " & sFileName Exit Sub Errhandler: ' If an error occurs, unhide and open the Settings sheet then display an error message Sheets("Settings").Visible = True Sheets("Settings").Activate MsgBox "An error has occurred. Please check that the PDF is not already open." End Sub 

———————-更新：————————– ———–

感谢您的所有input。 我确实得到了它的工作简单，但更多的玩，我已经卡住了。 我现在收到一个'下标我们的范围'错误与下面的代码在：

 If sheetNameArray(x) <> Empty Then 

有任何想法吗？

  Sub Run_Me_To_Create_Save_PDF() Dim saveAsName As String Dim WhereTo As String Dim sFileName As String Dim ws As Worksheet Dim myrange ReDim sheetNameArray(0 To 5) As String Dim NextWs As Worksheet Dim PreviousWs As Worksheet Dim x As Integer 'On Error GoTo Errhandler Sheets("Settings").Activate ' Retrieve value of 'Period Header' from Settings sheet Range("C4").Activate periodName = ActiveCell.Value ' Retrieve value of 'File Name' from Settings sheet Range("C5").Activate saveAsName = ActiveCell.Value ' Retrieve value of 'Publish PDF to Folder' from Settings sheet Range("C6").Activate WhereTo = ActiveCell.Value ' Check if Stamp-field has any value at all and if not, add the current date. If Stamp = "" Then Stamp = Date ' Assemble the filename sFileName = WhereTo & saveAsName & " (" & Format(CDate(Date), "DD-MMM-YYYY") & ").pdf" Set myrange = Worksheets("Settings").Range("range_sheetProperties") For Each ws In ActiveWorkbook.Worksheets printOrder = Application.VLookup(ws.Name, myrange, 4, False) If Not IsError(printOrder) Then printOrderNum = printOrder If printOrderNum <> Empty Then 'Add sheet to array num = printOrderNum - 1 sheetNameArray(num) = ws.Name End If End If Next MsgBox Join(sheetNameArray, ",") 'Order Tab sheets based on array x = 1 Do While Count < 6 If sheetNameArray(x) <> Empty Then Set PreviousWs = Sheets(sheetNameArray(x - 1)) Set NextWs = Sheets(sheetNameArray(x)) NextWs.Move after:=PreviousWs x = x + 1 Else Count = Count + 1 x = x + 1 End If Loop Sheets(sheetNameArray).Select 'Save the File as PDF ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFileName, Quality _ :=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _ OpenAfterPublish:=True ' open the Settings sheet before exiting Sheets("Settings").Activate MsgBox "PDF document has been created and saved to : " & sFileName Exit Sub Errhandler: ' If an error occurs, unhide and open the Settings sheet then display an error message Sheets("Settings").Visible = True Sheets("Settings").Activate MsgBox "An error has occurred. Please check that the PDF is not already open." End Sub 

Answer 1

你会想要在一个数组中定义工作表。

这个例子使用了一个静态数组，知道图纸顺序以及你想要预先打印的内容。 这确实有用。

 ThisWorkbook.Sheets(Array("Sheet1","Sheet2","Sheet6","Master","Sales")).Select ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sFileName, Quality _ :=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _ OpenAfterPublish:=True 

问题是，如果工作表被隐藏，则在select时将失败。

因此，在声明数组之前，您将需要知道哪些纸张可以通过要打印的testing。 因此，您将需要一个dynamic数组来构build工作表的列表。

我确实改变了PrintOrder的工作方式，而不是让工作表不可见，只是不把它添加到数组中，反之亦然，把你想要的数组添加到数组中。 然后你在最后select数组，然后运行你的打印macros。

我用我自己的testing值testing了这个，并且相信你的PrintOrdertesting工作正常。 但是这个工作。 我使用它来打印每天只有4小时以上的时间表，并且成功地将一张工作簿中的5张工作表与11张工作表合并为一个PDF文件。所有这些都符合testing的要求。

testing：插入此代替For Each ws，并添加与您的variables声明

 Sub DynamicSheetArray() Dim wsArray() As String Dim ws As Worksheet Dim wsCount As Long wsCount = 0 For Each ws In Worksheets printOrder = Application.VLookup(ws.Name, myrange, 4, False) If Not IsError(printOrder) Then If printOrder = "Y" Then wsCount = wsCount + 1 ReDim Preserve wsArray(1 To wsCount) 'Add sheet to array wsArray(wsCount) = ws.Name End If End If Next Sheets(wsArray).Select ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sFileName, Quality _ :=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _ OpenAfterPublish:=True End Sub 

编辑：进一步解释了我的代码的上下文到OP

Answer 2

这是我想出的一些代码。 基本上你会想要采取这个，并适应它，以适应您的具体需求，但一般的想法应该工作！

 Sub MovingPagesAccordingToNumberInRange() Dim ws As Worksheet Dim NextWs As Worksheet Dim PreviousWs As Worksheet Dim sheetNameArray(0 To 400) As String Dim i As Integer 'This first loop is taking all of the sheets that have a number ' placed in the specified range (I used Cell A1 of each sheet) ' and it places the name of the worksheet into an array in the ' order that I want the sheets to appear. If I placed a 1 in the cell ' it will move the name to the 1st place in the array (location 0). ' and so on. It only places the name however when there is something ' in that range. For Each ws In Worksheets If ws.Cells(1, 1).Value <> Empty Then num = ws.Cells(1, 1).Value - 1 sheetNameArray(num) = ws.Name End If Next ' This next section simply moves the sheets into their ' appropriate positions. It takes the name of the sheets in the ' previous spot in the array and moves the current spot behind that one. ' Since I didn't know how many sheets you would be using I just put ' A counter in the prevent an infinite loop. Basically if the loop encounters 200 ' empty spots in the array, everything has probably been organized. x = 1 Do While Count < 200 If sheetNameArray(x) <> Empty Then Set PreviousWs = sheets(sheetNameArray(x - 1)) Set NextWs = sheets(sheetNameArray(x)) NextWs.Move after:=PreviousWs x = x + 1 Else Count = Count + 1 x = x + 1 End If Loop End Sub