如何通过VBA循环行实现同一工作簿内Sheet1数据复制到Sheet2

需要实现同一工作簿内用Sheet1的数据填充Sheet2，具体场景示例如下：

填充规则 #

• Sheet1每一行的C列条目先复制到Sheet2，同时复制该行对应的A、B、E列关联信息
• 紧接着同一行的D列条目复制到Sheet2的下一行，同样携带对应A、B、E列关联信息
• 循环操作直到Sheet1所有行的数据都处理完毕

注：宏按钮放在其他工作表中，代码需要显式引用每个工作表，避免出现活动工作表指向错误的问题。

原代码问题说明 #

你提供的原始代码核心问题是赋值方向颠倒，把Sheet2的值赋值给了Sheet1，和需求完全相反；同时使用了低效的Select、ActiveCell操作，还存在未限定工作表归属的Range引用，按钮放在其他工作表时极易出现执行错误。

修正后可用VBA代码 #

Sub 按规则拆分填充Sheet2()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim NumRows As Long, i As Long, j As Long
    ' 显式定义工作表，避免按钮在其他表时引用错误
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    ' 获取Sheet1 C列有效数据行数
    NumRows = ws1.Range("C" & ws1.Rows.Count).End(xlUp).Row
    ' Sheet2从第4行开始写入，和原代码初始写入位置保持一致
    j = 4
    ' 遍历Sheet1所有数据行
    For i = 2 To NumRows
        ' 写入C列对应条目
        ws2.Cells(j, "A").Value = ws1.Cells(i, "A").Value
        ws2.Cells(j, "B").Value = ws1.Cells(i, "B").Value
        ws2.Cells(j, "C").Value = ws1.Cells(i, "C").Value
        ws2.Cells(j, "D").Value = ws1.Cells(i, "E").Value
        j = j + 1
        ' 写入D列对应条目
        ws2.Cells(j, "A").Value = ws1.Cells(i, "A").Value
        ws2.Cells(j, "B").Value = ws1.Cells(i, "B").Value
        ws2.Cells(j, "C").Value = ws1.Cells(i, "D").Value
        ws2.Cells(j, "D").Value = ws1.Cells(i, "E").Value
        j = j + 1
    Next i
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
End Sub

优化点说明 #

• 提前绑定工作表对象，无论宏按钮放在哪个工作表都能正确识别目标表
• 去掉了界面操作类语句，运行时不会跳转工作表，执行效率更高
• 自动识别有效数据行数，不需要额外判断空行终止条件
• 字段对应关系和原代码保持一致，可直接适配你的原有业务逻辑

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