每次使用循环将列中的每个单元格复制到新工作表中的特定单元格

Question

我寻求您的帮助，将第一个工作表（D 列）中的单元格值复制到 16 个现有工作表中的指定单元格位置

我想要价值
D2 在 sheet1 到 sheet2 (G5)

工作表 1 到工作表 3 中的 D3 (G5)

工作表 1 到工作表 4 中的 D4 (G5)

以此类推，直到 D16 复制到 sheet16 的 G5

我是新手，我查看了几个答案并试图自己解决，但是....什么也没发生

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 的尝试很好，但我不会使用shtname = "Sheet" & i，而是尝试以下解决方案并考虑对其进行防弹处理（工作表的存在）；）

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

试试这个。

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