VBA - ワークブックの別のテンプレートシートを別のワークブックの複数のシートにまとめて、要約シートの条件に基づいて複写する

Question

VBA（3日間のEXP）にはかなり新しく、いくつかのフォーラムを通して見た私は解決策を見つけることができません。

私は2つのワークブックを持っています。 「マスター」ブックには、同じブック内の空白の各シートにハイパーリンクされた列Aの名前の一覧が表示された要約シートがあり、そのタブには列の名前と同じラベルが付けられます。列Bには1または色の組み合わせがあります - 5つのオプション（赤、青、緑、青&赤、または赤&緑）があります。 私はラベルの赤、青、緑、青&赤、または赤&の緑に対応する5つのテンプレートシートをそれぞれ持っている別のテンプレートブックを持っています。

"マスタ"ワークブックのB列を通過するマクロを作成し、その色に応じて、テンプレートブックから対応するテンプレートをコピーし、次に隣接するリンクをクリックしてマスターブックに戻ります。列Aは空のシートに貼り付けてテンプレートを貼り付けます。これは列全体を繰り返すために繰り返す必要があります。例えば

：

1. は "マスター" ブック内のセルB2は、赤色を有することを認識する。
2. シートラベル
赤コピー用紙全体にB2の隣のセル内のハイパーリンク名に
4. バック「マスター」のワークブックに移動
5. クリック（A2）を行く
6. 、テンプレートブックを開きます。
7. はこれが貼り付け白紙
8. にテンプレート
9. は「マスター」のワークブックに戻り、列の残りの繰り返しをお連れします
10. もう一度赤い場合は、同じ操作を行い、青のような別の色の場合は青のテンプレートシートをコピーして貼り付けます。

私は他のフォーラムで利用可能だったものからコードを自分で書くことを試みたが、それが唯一の赤のテンプレートを必要とする10枚のうち「マスター」のワークブックの最初の2枚の上にペーストをコピーします。

Sub Summary()  
Dim rng As Range  
Dim i As Long  
Set rng = Range("B:B") 
For Each cell In rng  
If cell.Value <> "Red" Then cell.Offset(0, -1).select 
ActiveCell.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True 
Workbooks.Open Filename:= _ 
    "T:\Contracts\Colour Templates.xlsx" 


Sheets("Red Template").Select 
Cells.Select 
Selection.Copy 
Windows("Master.xlsx").Activate 
ActiveSheet.Range(“A1”).select 

ActiveSheet.Paste 
Next 
End Sub 

Answer 1

大丈夫なので、ここであなたが始めるためにいくつかのコードがあります：私は1つだけが動作していない場合は、複数の条件を追加するにはポイント以来、これまでに1色の基準のためにそれを書かれています。私はあなたが与えたコードの名前を基にしています。それがなぜ役に立つのです。私はあなたの学習を助けるためにこれをたくさんコメントしました、実際には約12行のコードしかありません！

注：このコードは「現状のまま」動作しない可能性があります。それを試してみて、オブジェクトブラウザ（VBAエディタでF2を押してください）とドキュメント（Google検索に「MSDN」を追加）を見てください。

Sub Summary() 

    ' Using the with statement means any code phrase started with "." assumes the With bit first 
    ' So ActiveSheet.Range("...") can now become .Range("...") 

    Dim MasterBook As Workbook 
    Set MasterBook = ActiveWorkbook 

    Dim HyperlinkedBook As Workbook 

    With MasterBook 

     ' Limit the range to column 2 (or "B") in UsedRange 
     ' Looping over the entire column will be crazy long! 

     Dim rng As Range 
     Set rng = Intersect(.UsedRange, .Columns(2)) 

    End With 

    ' Open the template book 
    Dim TemplateBook As Workbook 
    Set TemplateBook = Workbooks.Open(Filename:="T:\Contracts\Colour Templates.xlsx") 

    ' Dim your loop variable 
    Dim cell As Range 
    For Each cell In rng 

     ' Comparing values works here, but if "Red" might just be a 
     ' part of the string, then you may want to look into InStr 
     If cell.Value = "Red" Then 
      ' Try to avoid using Select 
      'cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True 

      ' You are better off not using hyperlinks if it is an Excel Document. Instead 
      ' if the cell contains the file path, use 

      Set HyperlinkedBook = Workbooks.Open(Filename:=cell.Offset(0, -1).Value) 

      ' If this is on a network drive, you may have to check if another user has it open. 
      ' This would cause it to be ReadOnly, checked using If myWorkbook.ReadOnly = True Then ... 

      ' Copy entire sheet 
      TemplateBook.Sheets("Red Template").Copy after:=HyperlinkedBook.Sheets(HyperlinkedBook.Sheets.Count) 

      ' Instead of copying whole sheet, copy UsedRange into blank sheet (copy sheet is better but here for learning) 
      ' HyperlinkedBook.Sheets.Add after:=HyperlinkedBook.Sheets.Count 
      ' TemplateBook.sheets("Red Template").usedrange.copy destination:=masterbook.sheets("PasteIntoThisSheetName").Range("A1") 

     ElseIf cell.Value = "Blue" Then 

      ' <similar stuff here> 

     End If 

    Next cell 

End Sub 

あなたが単純なタスクを行う方法を学ぶのを助けるためにマクロレコーダーを使用します。

http://www.excel-easy.com/vba/examples/macro-recorder.html

は、コードを編集し、Selectを使用しないよう、その後に試してみてください。

How to avoid using Select in Excel VBA macros

Answer 2

私は過去1週間、運がないコードを稼働させようとしてきました。私は様々な修正を試みましたが、最終的には異なるエラーコードが与えられます。私が最初に受け取ったエラーはSet rng = Intersect(.UsedRange, .Columns(2))で、 "オブジェクトはこのプロパティまたはメソッドをサポートしていません" それでは、これを変更して、それが機能するかどうかを確認するだけにしました。 Set rng = Range("B:B")。 私はそれを読むと、それは読み取られ、エラーコードSet HyperlinkedBook = Workbooks.Open(Filename:=cell.Offset(0, -1).Value)のエラーが表示されます。実行時エラー1004 24 James.xlsxが見つかりませんでした。移動したり、名前を変更したり、削除したりする可能性はありますか？」 このコード行では、ハイパーリンクがその名前の別のブックを開く必要があると想定していますが、そうではありません。要約シートのハイパーリンクは、同じマスターブックの他のシートにリンクします。テンプレートは別のブックにのみ存在します。 これを克服するために、私はこの行を変更してみました。テンプレートブックを開き、最初のシートにタブ名をコピーして、次の行にエラーを表示するコードを以下に示します。TemplateBook.Sheets("Red").Copy ActiveSheet.Paste 「範囲外の下付き」

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 

は、私はいくつかのより多くのバリエーションを試してみましたが、私はちょうどそれが正しいの要約シート上のリンクを介して、正しいテンプレートをコピーマスターブックに切り替える、従うことを得ることができませんシート（同じマスターワークブック内にある）を選択し、テンプレートを貼り付けます。