Excel VBA：复制表格后为新增相同行数填充对应日期与姓名

最优修正方案 #

核心逻辑是粘贴前先确定本次复制的行数、粘贴起始行，直接针对新增行范围批量赋值，完全不触碰历史数据，也不需要循环遍历全表，性能最优。

完整可运行代码

Dim TblToSave As Range
Dim RangeToPaste As Range
Dim copyRowCount As Long
Dim pasteStartRow As Long
Dim wsSource As Worksheet, wsDb As Worksheet

' 绑定工作表对象，避免重复调用以及引用错误
Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Set wsDb = ThisWorkbook.Worksheets("Db")

' 定位要复制的源区域，补全工作表引用避免活跃页错位问题
' 如果源数据中间有空行，可替换为下方注释中的定位逻辑
Set TblToSave = wsSource.Range("D22", wsSource.Range("O22").End(xlDown))
' 空行兼容写法：
' Dim sourceLastRow As Long
' sourceLastRow = wsSource.Range("O" & wsSource.Rows.Count).End(xlUp).Row
' Set TblToSave = wsSource.Range("D22:O" & sourceLastRow)

' 统计本次复制的行数
copyRowCount = TblToSave.Rows.Count

' 计算粘贴起始行
pasteStartRow = wsDb.Range("C" & wsDb.Rows.Count).End(xlUp).Row + 1
Set RangeToPaste = wsDb.Range("C" & pasteStartRow)

' 粘贴数值，不需要调用Activate
TblToSave.Copy
RangeToPaste.PasteSpecial xlPasteValues
Application.CutCopyMode = False ' 清空剪贴板释放资源

' 批量给本次新增行的A、B列赋值，不需要循环
wsDb.Range("A" & pasteStartRow & ":A" & pasteStartRow + copyRowCount - 1).Value = wsSource.Range("A19").Value ' 日期
wsDb.Range("B" & pasteStartRow & ":B" & pasteStartRow + copyRowCount - 1).Value = wsSource.Range("A5").Value ' 姓名

优化说明

• 仅操作本次新增的行范围，100%不会修改历史数据
• 批量赋值性能远高于逐行遍历判断，单次粘贴上万行也不会有卡顿
• 移除了Activate这类不稳定的操作，代码健壮性更高
• 行计数变量使用Long类型，避免行数超过32767时的溢出报错
• 补全了所有单元格的工作表引用，避免当前活跃工作表不是源表时的定位错误

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