VBA循环复制单元格始终覆盖同一目标单元格，无法逐行下移求助

看起来你遇到的核心问题是每次复制的内容都覆盖了同一个目标单元格，没法实现逐行下移粘贴。这是因为你只在循环开始前初始化了一次CopyR，后续复制操作一直指向同一个位置，自然会把之前的内容覆盖掉。

先给你拆解代码里的几个小问题，再给你修正后的完整代码：

问题点梳理 #

1. Option Explicit位置错误：它必须放在模块的最顶部（所有过程代码之前），不然会触发编译错误。
2. CopyR未声明：因为你用了Option Explicit强制变量声明，所有变量都得提前声明，否则会报错。
3. 目标粘贴位置未更新：循环里每次复制后，没有让CopyR自动下移一行，导致所有内容都粘到同一个单元格。

修正后的完整代码 #

Option Explicit

Sub count()
    Dim r As Range, i As Long, lastrow As Long, ro As Range, sh As Worksheet
    Dim cuweek As Range, myrange As Range, CopyR As Range ' 新增CopyR的变量声明
    
    ' 获取Sheet3中A列最后一行的下一行，作为初始粘贴位置
    lastrow = Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Row
    Set CopyR = Sheets("Sheet3").Cells(lastrow, "A").Offset(1, 0)
    
    Set cuweek = Sheets("Dashboard").Range("G5")
    Set sh = Sheets("Input")
    Set ro = sh.Range("B3:TC3")
    
    For Each r In ro
        Set myrange = r.Offset(2, 0)
        ' 检查当前单元格的周数是否匹配目标周数（加上.Value更清晰）
        If WorksheetFunction.WeekNum(r.Value) = cuweek.Value Then
            myrange.Copy Destination:=CopyR
            ' 关键改动：每次粘贴后，把目标位置下移一行
            Set CopyR = CopyR.Offset(1, 0)
        End If
    Next
End Sub

关键改动说明 #

• 把Option Explicit移到了模块最顶部，符合VBA的语法规范。
• 新增了CopyR的变量声明，避免未声明变量导致的编译错误。
• 在每次完成复制粘贴后，通过Set CopyR = CopyR.Offset(1, 0)让目标粘贴位置自动下移一行，这样下一次复制的内容就会粘到新的行，不会覆盖之前的内容。
• 建议在比较时加上.Value（比如r.Value和cuweek.Value），虽然VBA会默认读取单元格的值，但明确写出能让代码逻辑更清晰，避免潜在的引用问题。

这样修改后，你的代码应该就能实现逐行粘贴符合条件的单元格内容了。

内容的提问来源于stack exchange，提问作者G_TTI