条件に基づいて特定のセルを別のワークブックの基準と同じラベルのシートにコピー

Question

次のタスクのコードを記述しようとしていますが、かなり苦労しています。 私は2つのワークブック、wb1とwb2を持っています。 wb1には列Aに名前のリストがあるテーブルがあり、次に列B-Vには列Aと同じ名前で別のブック（wb2）にコピーしたいデータがあります。貼り付けられた場所は、wb2の宛先シートの別の条件にも依存します。

たとえば、 "John"はA1の名前、wb2に切り替え、Johnというシートに移動し、このシートのセルA4の基準を確認します。 次の3つの基準があります。ティーンは、その後、大人は、その後、B135にF1をコピーし、B97にコピーJ1をコピーする場合B135にC1をコピーし、B147 & B190にD1をコピーし、B1100

にE4をコピーし、B97にB1をコピーする場合

またはエルダーG1をB147 & B190にコピーし、H4をB1100にコピーします。

エルダーがB1をB97にコピーすると、co B135へPY C1、B1100にE4をコピーし、B147 & B190にD1をコピーし、B113にJ1をコピーし、B1910にF1をコピーし、B1473 & B1930にG1をコピーし、B1190

にH4をコピー（上記一例であり、上にリストしたものより多くのセルを貼り付ける）

これは、wb1の列Aのすべての名前に対してループする必要があります。

以下はマクロレコードが私に与えたものですが、基準を記録していません。どちらのワークブックも開いています。

Sub Summary() 

    Dim wb1 As Workbook 
    Dim Sht As Worksheet 
    Dim Rng, Rng2 As Range 

    Set wb1= ThisWorkbook 
    Set Sht = MasterBook.Worksheets("Sheet") 
    Set Rng = Sht.Range("A2:A" & Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row) 
    Dim wb2 As Workbook 
    Dim cell As Range 
    For Each cell In Rng '<---Here is where my first problem is, 
'not sure how to get the excel to switch to the sheet 
'with the same name as in column A then check cell A4 for the criteria' 

    If cell.Value = "Teen" Then 
    Range("C12").Select 
     Selection.Copy 
     Windows("wb2.xlsx").Activate 
     ActiveWindow.SmallScroll Down:=81 
     Range("B97").Select 
     ActiveSheet.Paste 
     ActiveWindow.SmallScroll Down:=-9 
     Windows("wb1.xlsx").Activate 
     Range("D12").Select 
     Application.CutCopyMode = False 
     Selection.Copy 
     Windows("wb2.xlsx").Activate 
     ActiveWindow.SmallScroll Down:=12 
     Range("B95").Select 
     ActiveSheet.Paste 
     Windows("wb1.xlsx").Activate 
     Range("E12").Select 
     Application.CutCopyMode = False 
     Selection.Copy 
     Windows("wb2.xlsx").Activate 
     ActiveWindow.SmallScroll Down:=-45 
     Range("B47").Select 
     ActiveSheet.Paste 
     ActiveWindow.SmallScroll Down:=63 
     Range("B118").Select 
     ActiveSheet.Paste 
     Windows("wb1.xlsx").Activate 
     Range("F12").Select 
     Application.CutCopyMode = False 
     Selection.Copy 
     Windows("wb2.xlsx").Activate 
     ActiveWindow.SmallScroll Down:=48 
     Range("B163").Select 
     ActiveSheet.Paste 
     Windows("wb1.xlsx").Activate 
     Range("G12").Select 
     Application.CutCopyMode = False 
     Selection.Copy 
     Windows("wb2.xlsx").Activate 
     ActiveWindow.SmallScroll Down:=-66 
     Range("B93").Select 
     ActiveSheet.Paste 
     Windows("wb1.xlsx").Activate 
     Range("H12").Select 
     Application.CutCopyMode = False 
     Selection.Copy 
     Windows("wb2.xlsx").Activate 
     ActiveWindow.SmallScroll Down:=9 
     Range("B105").Select 
     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
      :=False, Transpose:=False 
     ActiveWindow.SmallScroll Down:=60 
     Range("B167").Select 
     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
      :=False, Transpose:=False 
     Windows("wb1.xlsx").Activate 
     Range("I12").Select 
     Application.CutCopyMode = False 
     Selection.Copy 
     Windows("wb2.xlsx").Activate 
     ActiveWindow.SmallScroll Down:=-27 
     Range("B141").Select 
     ActiveSheet.Paste 
     Windows("wb1.xlsx").Activate 
     Range("J12").Select 
     Application.CutCopyMode = False 
     Selection.Copy 
     Windows("wb2.xlsx").Activate 
     Range("B145").Select 
     ActiveSheet.Paste 
     ActiveWindow.SmallScroll Down:=138 
     Windows("wb1.xlsx").Activate 
     Windows("wb2.xlsx").Activate 
     ActiveWindow.SmallScroll Down:=51 
     Range("B326").Select 
     ActiveSheet.Paste 
     ActiveWindow.SmallScroll Down:=12 
     Range("B339").Select 
     Application.CutCopyMode = False 
     ActiveCell.FormulaR1C1 = "1" 
     Range("B317").Select 
     ActiveCell.FormulaR1C1 = "1" 
     Range("B312").Select 
     ActiveCell.FormulaR1C1 = "1" 
     Windows("wb1.xlsx").Activate 
     Range("K12").Select 
     Selection.Copy 
     Windows("wb2.xlsx").Activate 
     Range("B107").Select 
     ActiveSheet.Paste 
     ActiveWindow.SmallScroll Down:=-63 
     Range("B49").Select 
     ActiveSheet.Paste 
     ActiveWindow.SmallScroll Down:=-9 
     Windows("wb1.xlsx").Activate 
     Windows("wb2.xlsx").Activate 
     ActiveWindow.SmallScroll Down:=306 
     Windows("wb1.xlsx").Activate 

    else If cell.Value = "Adult" Then 
    '<-----same stuff as above for different cells copy pasted' 
    else If cell.Value = "Elder" Then 
    '<-----same stuff as above for different cells copy pasted' 
end if 
    End Sub 

また、ここでIf文の代わりにcase関数が役立つかどうかはわかりません。

どうもありがとう事前に

EDIT 1

は私が

Sub Summary() 

    Dim wb1 As Workbook 
    Dim Sht As Worksheet 
    Dim Rng, Rng2 As Range 
    Dim wb2 As Workbook 
    Dim cell As Range 

    Set wb1 = ThisWorkbook 
    Set wb2 = Workbooks("Measure Templates.xlsx") 
    Set Sht = wb1.Worksheets("Summary") 
    Set Rng = Sht.Range("A5:A" & Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row) 

    For Each cell In Rng 
     Select Case wb2.Sheets(cell.Text).Range("A4").Value 
      Case "Standard Bathroom Template" 
      wb1.Sheet("Summary").Range("B5").Value = wb2.ActiveSheet.Range("B97") '<--- I'm getting an error here saying "Object doesn't support this property or method" 
'I assume that this is not the right way to copy paste. 
'I looked around but everything online uses a specific sheet name for destination 
'which is not the case for me, it should be sheet with same name as in column A 
       wb1.Sheet("Summary").Range("C5").Value = wb2.ActiveSheet.Range("B117") 
       Case "Standard Kitchen Template" 
       wb1.Sheet("Summary").Range("B6").Value = wb2.ActiveSheet.Range("B97") 
       wb1.Sheet("Summary").Range("C6").Value = wb2.ActiveSheet.Range("B117") 
       Case "Standard Bathroom and Kitchen T" 
       wb1.Sheet("Summary").Range("B7").Value = wb2.ActiveSheet.Range("B97") 
       wb1.Sheet("Summary").Range("C7").Value = wb2.ActiveSheet.Range("B117") 
      End Select 
     Next cell 

    End Sub 

Answer 1

の下に提案されているように更新したコードを変更し、関連を指すシート変数（WS）を追加しましたコピー用のシート（選択またはアクティブにする必要はありません）。

Sub Summary() 

    Dim wb1 As Workbook 
    Dim Sht As Worksheet 
    Dim Rng, Rng2 As Range 
    Dim wb2 As Workbook 
    Dim cell As Range 
    Dim ws as Worksheet 

    Set wb1 = ThisWorkbook 
    Set wb2 = Workbooks("Measure Templates.xlsx") 
    Set Sht = wb1.Worksheets("Summary") 
    Set Rng = Sht.Range("A5:A" & Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row) 

    For Each cell In Rng 
     Set ws=wb2.Sheets(cell.Text) 
     Select Case ws.Range("A4").Value 
      Case "Standard Bathroom Template" 
      wb1.Sheet("Summary").Range("B5").Value = ws.Range("B97").Value 
      wb1.Sheet("Summary").Range("C5").Value = ws.Range("B117").Value 
       Case "Standard Kitchen Template" 
       wb1.Sheet("Summary").Range("B6").Value = ws.Range("B97").Value 
       wb1.Sheet("Summary").Range("C6").Value = ws.Range("B117").Value 
       Case "Standard Bathroom and Kitchen T" 
       wb1.Sheet("Summary").Range("B7").Value = ws.Range("B97").value 
       wb1.Sheet("Summary").Range("C7").Value = ws.Range("B117").Value 
      End Select 
     Next cell 

    End Sub