ループを使用して同じ手順を繰り返しますが、他の条件を使用します

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

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 

Answer 2

これはあなたの望むものではありませんが、開始するのに役立ちます。新しい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