如何使用VBA按定义的顺序循环浏览工作表_Vba_Excel

如何使用VBA按定义的顺序循环浏览工作表

vba excel

如何使用VBA按定义的顺序循环浏览工作表,vba,excel,Vba,Excel,我有下面的工作代码，它在每个工作表中循环，如果范围（myrange）中定义的值为“Y”，它会将这些工作表输出到单个PDF文档中。我的挑战是，我想根据范围内的数值（例如1,2,3,4,5,6,7等）而不是“Y”，定义它们在PDF中的输出顺序。我计划使用myrange中的同一列来检查它是否需要输出为PDF，只需将“Y”替换为数字，如“1”和“2” 目前，订单是根据工作表选项卡的位置定义的。从左到右任何帮助都将不胜感激 Sub Run_Me_To_Create_Save_PDF() Dim

我有下面的工作代码，它在每个工作表中循环，如果范围（myrange）中定义的值为“Y”，它会将这些工作表输出到单个PDF文档中。我的挑战是，我想根据范围内的数值（例如1,2,3,4,5,6,7等）而不是“Y”，定义它们在PDF中的输出顺序。我计划使用myrange中的同一列来检查它是否需要输出为PDF，只需将“Y”替换为数字，如“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

-------------------------更新：-------------------------------------

感谢您迄今为止的所有投入。我确实让它短暂地发挥了作用，但随着更多的比赛，我已经陷入困境。我现在收到一个“范围下标”错误，代码如下：

If sheetNameArray(x) <> Empty Then

如果sheetNameArray（x）为空，则

有什么想法吗

        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

Sub-Run\u Me\u To\u Create\u Save\u PDF（）
将saveAsName设置为字符串
把什么地方当作绳子
将sFileName设置为字符串
将ws设置为工作表
暗视野
将sheetNameArray（0到5）重拨为字符串
将下一个工作表设置为工作表
将上一个窗口设置为工作表
作为整数的Dim x
'在出现错误时转到Errhandler
工作表（“设置”）。激活
'从设置表中检索'Period Header'的值
射程（“C4”）。激活
periodName=ActiveCell.Value
'从设置表中检索“文件名”的值
范围（“C5”）。激活
saveAsName=ActiveCell.Value
'从设置表中检索“将PDF发布到文件夹”的值
范围（“C6”）。激活
WhereTo=ActiveCell.Value
'检查Stamp字段是否有任何值，如果没有，则添加当前日期。
如果Stamp=”“，则Stamp=日期
'汇编文件名
sFileName=WhereTo&saveAsName&（“&Format（CDate（Date），“DD-MMM-YYYY”）&“.pdf”
设置myrange=工作表（“设置”）.Range（“范围属性”）
对于ActiveWorkbook.Worksheets中的每个ws
printOrder=Application.VLookup（ws.Name，myrange，4，False）
如果不是IsError（打印订单），则
printOrderNum=printOrder
如果printOrderNum为空，则
'将工作表添加到数组
num=printOrderNum-1
sheetNameArray（num）=ws.Name
如果结束
如果结束
下一个
MsgBox联接（sheetNameArray，“，”）
'基于数组的订单选项卡工作表
x=1
当计数小于6时执行此操作
如果sheetNameArray（x）为空，则
设置PreviousWs=Sheets（sheetNameArray（x-1））
Set NextWs=图纸（sheetNameArray（x））
NextWs.Move after:=PreviousWs
x=x+1
其他的
计数=计数+1
x=x+1
如果结束
环
工作表（sheetNameArray）。选择
'将文件另存为PDF
ActiveSheet.ExportAsFixedFormat类型：=xlTypePDF，文件名：=sFileName，质量_
：=xlQualityStandard，IncludeDocProperties:=True，IgnorePrintAreas:=False_
OpenAfterPublish:=True
'退出前打开设置表
工作表（“设置”）。激活
MsgBox“PDF文档已创建并保存到：”&sFileName
出口接头
错误处理程序：
'如果发生错误，请取消隐藏并打开设置表，然后显示错误消息
工作表（“设置”）。可见=真
工作表（“设置”）。激活
MsgBox“发生错误。请检查PDF是否尚未打开。”
端接头

以下是我想到的一些代码。基本上，你会想采取这一点，并适应它，以满足您的具体需求，但总的想法应该工作

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

Sub-MovingPagesAccordingToNumberInRange（）
将ws设置为工作表
将下一个工作表设置为工作表
将上一个窗口设置为工作表
作为字符串的尺寸sheetNameArray（0到400）
作为整数的Dim i
'第一个循环将获取所有具有数字的工作表
'放置在指定范围内（我使用每张图纸的单元格A1）
'并将工作表的名称放入
'命令我希望图纸显示。如果我在牢房里放一个1
'它会将名称移动到数组中的第一位（位置0）。
”“等等。它只在有东西的时候才放名字
“在这个范围内。
对于工作表中的每个ws
如果ws.Cells（1，1）.Value为空，则
num=ws.Cells（1，1）.Value-1
sheetNameArray（num）=ws.Name
如果结束
下一个
'下一节只是将图纸移动到其位置
"适当的位置。它采用表格中表格的名称
'并将当前点移到该点之后。
“因为我不知道你会用多少张纸，所以我就放了
'中的计数器阻止无限循环。基本上如果循环遇到200
“阵列中的空白点，一切都可能已经组织好了。
x=1
当计数小于200时进行
如果sheetNameArray（x）为空，则
设置PreviousWs=sheets（sheetNameArray（x-1））
Set NextWs=图纸（sheetNameArray（x））
NextWs.Move after:=PreviousWs
x=x+1
其他的
计数=计数+1
x=x+1
如果结束
环
端接头

您可能希望在数组中定义工作表

本例使用静态数组，提前知道图纸顺序和要打印的内容。这确实有效

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

问题是，如果图纸被隐藏，它将在选择时失败

因此，您需要已经知道哪些纸张通过

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