VBA - 条件が満たされている場合、別のブックの複数のシートにテンプレートシートをコピー

Question

私は運が悪い過去1週間のコードを取得しようとしています。私は様々な修正を試みましたが、最終的には異なるエラーコードが与えられます。ちょうどかどうかを確認するために

は私がなっていた最初のエラーが

だから、私はちょうど列全体を経由し、これを変更し、このプロパティまたはメソッドをサポートしていませんSet rng = Intersect(.UsedRange, .Columns(2))

オブジェクトとありましたそれは動作します：Set rng = Range("B:B")、私はそれを介して読み取り、それはエラーコードのエラーが表示されます：

ランタイムエラー1004申し訳ありませんでした.24 James.xlsx

移動、名前変更、削除が可能ですか？

このコード行では、ハイパーリンクが別のブックをその名前で開く必要があると想定していますが、そうではありません。要約シートのハイパーリンクは、同じマスターブックの他のシートにリンクします。テンプレートは別のブックにのみ存在します。

これを克服するために、この行を変更してみて、テンプレートブックを開いて最初のシートにタブ名だけをコピーして、次の行にエラーを表示するコードTemplateBook.Sheets("Red").Copy ActiveSheet.Paste、FOL、マスターワークブックのシートに切り替え、私はいくつかのより多くのバリエーションを試してみましたが、私はちょうどそれが正しいテンプレートをコピーすることができません

範囲外の添字

Sub Summary() 

    Dim MasterBook As Workbook 

    Set MasterBook = ActiveWorkbook 
    With MasterBook  
     Dim rng As Range 
     Set rng = Range("B:B")  
    End With 
    Dim TemplateBook As Workbook 
    Set TemplateBook = Workbooks.Open(Filename:=" C:\Users\Desktop\Example template.xlsx") 

    Dim cell As Range 
    For Each cell In rng 
     If cell.Value = "Red" Then 
      cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True 
      TemplateBook.Sheets("Red").Copy ActiveSheet.paste 
     ElseIf cell.Value = "Blue" Then 
cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True 
      TemplateBook.Sheets("Blue").Copy ActiveSheet.paste 
     End If  
    Next cell 

End Sub 

を言って同じマスターブックのシートを修正するためのリンクをクリックし、テンプレートを貼り付けます。私はあなたのコードに加えられた変更について

Answer 1

いくつかのコメント：

1. 代わりに全体列Bを使用するのでは、その中の値を持つ列Bのセルのみを使用するようにしてください。

2. ActiveWorkbookを使用しないようにしてください。コードが同じブックにある場合は、代わりにThisWorkbookを使用してください。 Set Rng = Sht.Range("B1:B" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row)：あなたはRangeを設定すると

3. することは、完全にのように、WorkbookとWorksheetを示すことによって、それを修飾します。

4. の代わりにSelect Caseを使用しました。その結果、両方が同じであり、今後さらに柔軟に対応できるようになります。

5. TemplateBook.Sheets("Red")でシート全体をコピーして別のブックに貼り付けると、構文はTemplateBook.Sheets("Red").Copy after:=Shtになります。

コード

Option Explicit 

Sub Summary() 

    Dim MasterBook As Workbook 
    Dim Sht As Worksheet 
    Dim Rng As Range 

    Set MasterBook = ThisWorkbook '<-- use ThisWorkbook not ActiveWorkbook 
    Set Sht = MasterBook.Worksheets("Sheet3") '<-- define the sheet you want to loop thorugh (modify to your sheet's name)     
    Set Rng = Sht.Range("B1:B" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row) '<-- set range to all cells in column B with values 

    Dim TemplateBook As Workbook 
    Set TemplateBook = Workbooks.Open(Filename:="C:\Users\Desktop\Example template.xlsx") 

    Dim cell As Range 

    For Each cell In Rng 
     Select Case cell.Value 
      Case "Red", "Blue" 
       cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True '<-- not so sure what values you have here 
       TemplateBook.Sheets(cell.Value).Copy after:=Sht '<-- paste after the sheet defined 
      Case Else 
       ' do something if you have other cases , not sure it's needed 
     End Select 
    Next cell 

End Sub 

---

編集1：下のループを使用し、シートの>>ペースト内容をコピーするには：

For Each cell In Rng 
    Select Case cell.Value 
     Case "Red", "Blue" 
      cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True '<-- not so sure what values you have here 
      Application.CutCopyMode = False 
      TemplateBook.Sheets(cell.Value).UsedRange.Copy 
      Sht.Range("A1").PasteSpecial  '<-- paste into the sheet at Range("A1") 

     Case Else 
      ' do something if you have other cases , not sure it's needed 
    End Select 
Next cell 

---

編集2：は、新しいワークシートを作成し、cell.Offset(0, -1).Value

TemplateBook.Sheets(cell.Value).Copy after:=Sht 

Dim CopiedSheet As Worksheet 
Set CopiedSheet = ActiveSheet 
CopiedSheet.Name = cell.Offset(0, -1)