For each loop applying value of one cell to entire content

[canyon]

I've got this set of code:

Sub loopthru()

    Dim rng As Range
    Dim mycell As Range
    
    Set rng = Range("A2:A78")
    For Each mycell In rng
        Windows("wb1.xlsx").Activate
        mycell.Copy
        Windows("wb2.xlsx").Activate
        Range("G2").Select
        Range("G2").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
        Range("G3").Select
        Range("G3").Copy
        Windows("wb1.xlsx").Activate
        Range("D2:D78").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False

    Next
End Sub

When I run it the code only takes the last value of column A and applies its output (taken from WB2 cell G3) to the entire contents of column D (Range D2:D78). How can I do this differently so that each of the values is unique to the input of column A?

 

[Fluff]

How about

Sub loopthru()

    Dim rng As Range
    Dim mycell As Range
   
    Set rng = Range("A2:A78")
    For Each mycell In rng
        Windows("wb1.xlsx").Activate
        mycell.Copy
        Windows("wb2.xlsx").Activate
        Range("G2").Select
        Range("G2").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
        Range("G3").Select
        Range("G3").Copy
        Windows("wb1.xlsx").Activate
        mycell.Offset(, 3).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False

    Next
End Sub

 

[canyon]

How about

Sub loopthru()

    Dim rng As Range
    Dim mycell As Range
  
    Set rng = Range("A2:A78")
    For Each mycell In rng
        Windows("wb1.xlsx").Activate
        mycell.Copy
        Windows("wb2.xlsx").Activate
        Range("G2").Select
        Range("G2").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
        Range("G3").Select
        Range("G3").Copy
        Windows("wb1.xlsx").Activate
        mycell.Offset(, 3).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False

    Next
End Sub

It works! Thank you!

 

[Fluff]

You're welcome & thanks for the feedback.