copy every cells in a column to particular cell in new sheet every time with a loop

Question

I seek your help to copy the cell values in (column D) of the first worksheet to a specified cell location in 16 existing worksheets

i want value in
D2 in in sheet1 to sheet2 (G5)

D3 in in sheet1 to sheet3 (G5)

D4 in in sheet1 to sheet4 (G5)

and so on until the D16 is copied to G5 of sheet16

i am a newbie, i looked into several answers and tried to work out on my own but.... nothing happened

Sub latitude()
Dim WS_Count As Integer
Dim I As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For I = 1 To WS_Count
Do Until IsEmpty(ActiveCell)
Sheets("Calculations").Select
Range("d2").Copy
    ActiveCell.Offset(1, 0).Select
'at this point i want it to copy "D3" on next loop
ActiveSheet.Range("G5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Loop
ActiveSheet.Next.Select
' and because the "Sheets("Calculations").Select" above takes it to the first sheet the whole script is a waste till now
Next I
End Sub

Answer 1

Alistairs attempt is good, i would however not use shtname = "Sheet" & i, instead try the following solution and think about bulletprooving it a bit (existance of worksheets) ;)

Sub Copy_to_G5()
    Dim i As Integer

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    i = 2
    Do Until i = 17
        With ThisWorkbook
        .Worksheets(1).Cells(i, 4).Copy
        .Worksheets(i).Range("G5").PasteSpecial
        End With
    i = i + 1
    Loop

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

Answer 2

Give this a try.

Option Explicit
Sub Copy_to_G5()
    Dim sht1 As Worksheet, ws As Worksheet
    Dim i As Integer
    Dim shtname As String

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    Set sht1 = Sheets("Sheet1")
    i = 2
    Do Until i = 17
        shtname = "Sheet" & i
        sht1.Cells(i, 4).Copy
        Sheets(shtname).Range("G5").PasteSpecial
    i = i + 1
    Loop

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub