使用循环重复相同的步骤但使用其他条件

Question

我在下面的代码中挣扎，我想重复所有步骤，但使用之前根据活动工作簿中的单元格值声明的不同标准。我指出了它阻塞的地方...

提前致谢。

Private Sub Validation()
Dim wbk As Workbook, wkshm As Worksheet, wksGI As Worksheet, wks1 As Worksheet, wks2 As Worksheet, wks3 As Worksheet
Dim wbkNew As Workbook, WSnew1 As Worksheet, WSnew2 As Worksheet, WSnew3 As Worksheet, wsnewGI As Worksheet, ws As Worksheet
Dim RNG1 As String, RNG2 As String, RNG3 As String, RNG As String, WSnew(3) As Worksheet, wks(3) As Worksheet
Dim sheettype As String, worksht1 As String, worksht2 As String, worksht3 As String, i, sh As Integer, worksht As String

Set wbk = ActiveWorkbook
Set wksGI = wbk.Sheets("General Info & Validation")
Set wkshm = wbk.Sheets("Homepage")
Set wbkNew = Workbooks.Add(xlWBATWorksheet)
Set wsnewGI = wbkNew.Worksheets(1)
sheettype = wkshm.range("TYPE")
RNG = "RNG"
worksht = "worksht"
wsnewGI.Name = wksGI.Name

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With

Select Case sheettype
    Case "FAC-19"
        worksht3 = "FAC-19"
        worksht2 = "FAC-19 rebate analysis"
        worksht1 = "FAC-19 Comments"
        RNG3 = "A1:K258"
        RNG2 = "A1:AF73"
        RNG1 = "A1:J90"
        sh = 3
    Case "FAC-20"
        worksht2 = "FAC-20"
        worksht1 = "FAC-19 rebate analysis"
        RNG2 = "A1:N140"
        RNG1 = "A1:AF73"
        sh = 2
    Case "Bid Summary"
        worksht3 = wbk.Sheets("Advance Validation Bid").Name
        worksht2 = wbk.Sheets("Bid Summary").Name
        worksht1 = wbk.Sheets("Bid Rebate Analysis").Name
        RNG1 = "A1:AG78"
        RNG2 = "A1:AF187"
        RNG3 = "A1:M99"
        sh = 3
    Case Else
        MsgBox "Nothing to request for validation!", vbInformation, " No validation"
        Exit Sub
End Select

For i = 1 To sh
    Set WSnew(i) = wbkNew.Worksheets.Add(After:=Worksheets(wsnewGI.Name))
    Set wks(i) = wbk.Sheets(worksht & i)  >As from here it blocks
    WSnew(i).Name = wks(i).Name  
    Set RNG(i) = wks(i).range(RNG & i) 
    RNG(i).Copy
    With WSnew(i)
        With .range("A1")
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
        End With
        .Activate
        .range("A1").Select
        With .PageSetup
            .PrintArea = RNG & i
            .Orientation = xlLandscape
            .Zoom = False
            .FitToPagesTall = 1
            .FitToPagesWide = 2
            .LeftMargin = Application.InchesToPoints(0.3)
            .RightMargin = Application.InchesToPoints(0.3)
            .TopMargin = Application.InchesToPoints(0.6)
            .BottomMargin = Application.InchesToPoints(0.6)
            .HeaderMargin = Application.InchesToPoints(0.3)
            .FooterMargin = Application.InchesToPoints(0.3)
        End With
    End With
Next i

For Each ws In wbkNew.Worksheets
    ws.Select
    With ActiveWindow
        .Zoom = 85
        .DisplayGridlines = False
    End With
Next ws

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

Answer 1

这不是您想要的，但它可以帮助您入门。新建一个excel，将工作表命名为"MySheet1"、"MySheet2"和"MySheet3"，运行代码如下。我想指出的是，在循环内部，工作表不被视为数组元素。我可能是错的，但我认为你应该再考虑一下你的那段代码。

Private Sub Example()
    Dim a(3) As Variant 'An array

    Set wbk = ActiveWorkbook

    a(1) = "MySheet1"
    a(2) = "MySheet2"
    a(3) = "MySheet3"

    For i = 1 To 3
        Set wks = wbk.Sheets(a(i)) 'This line is key to what you want to achieve
        wks.Cells(1, 1) = "Hi, you're in sheet number " & i & " and is named " & a(i)
    Next
End Sub

Answer 2

Private Sub Validation()
Dim wbk As Workbook, wkshm As Worksheet, wksGI As Worksheet
Dim wbkNew As Workbook, wsnewGI As Worksheet, ws As Worksheet
Dim RNG(3) As String, WSnew(3) As Worksheet, wks(3) As Worksheet
Dim sheettype As String, i As Integer, sh As Integer, worksht(3) As String, rnges(3) As range

Set wbk = ActiveWorkbook
Set wksGI = wbk.Sheets("General Info & Validation")
Set wkshm = wbk.Sheets("Homepage")
Set wbkNew = Workbooks.Add(xlWBATWorksheet)
Set wsnewGI = wbkNew.Worksheets(1)
sheettype = wkshm.range("TYPE")
wsnewGI.Name = wksGI.Name

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With

Select Case sheettype
    Case "FAC-19"
        worksht(3) = "FAC-19"
        worksht(2) = "FAC-19 rebate analysis"
        worksht(1) = "FAC-19 Comments"
        RNG(3) = "A1:K258"
        RNG(2) = "A1:AF73"
        RNG(1) = "A1:J90"
        sh = 3
    Case "FAC-20"
        worksht(2) = "FAC-20"
        worksht(1) = "FAC-19 rebate analysis"
        RNG(2) = "A1:N140"
        RNG(1) = "A1:AF73"
        sh = 2
    Case "Bid Summary"
        worksht(3) = "Advance Validation Bid"
        worksht(2) = "Bid Summary"
        worksht(1) = "Bid Rebate Analysis"
        RNG(3) = "A1:AG78"
        RNG(2) = "A1:AF187"
        RNG(1) = "A1:M99"
        sh = 3
    Case Else
        MsgBox "Nothing to request for validation!", vbInformation, " No validation"
        Exit Sub
End Select

For i = 1 To sh
    Set WSnew(i) = wbkNew.Worksheets.Add(After:=Worksheets(wsnewGI.Name))
    Set wks(i) = wbk.Sheets(worksht(i)) 
    WSnew(i).Name = wks(i).Name
    Set rnges(i) = wks(i).range(RNG(i))
    rnges(i).Copy
    With WSnew(i)
        With .range("A1")
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
        End With
        .Activate
        .range("A1").Select
        With .PageSetup
            .PrintArea = RNG(i)
            .Orientation = xlLandscape
            .Zoom = False
            .FitToPagesTall = 1
            .FitToPagesWide = 2
            .LeftMargin = Application.InchesToPoints(0.3)
            .RightMargin = Application.InchesToPoints(0.3)
            .TopMargin = Application.InchesToPoints(0.6)
            .BottomMargin = Application.InchesToPoints(0.6)
            .HeaderMargin = Application.InchesToPoints(0.3)
            .FooterMargin = Application.InchesToPoints(0.3)
        End With
    End With
Next i

For Each ws In wbkNew.Worksheets
    ws.Select
    With ActiveWindow
        .Zoom = 85
        .DisplayGridlines = False
    End With
Next ws

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

使用循环重复相同的步骤但使用其他条件

Using loop to repeat same steps but with other criteria

excel

vba

for-loop

range

worksheet