VBA跨工作表复制异常：目标表数据始终覆盖首行求排查

我来帮你梳理这个问题的解决思路和最终修正方案：

问题回顾 #

你遇到的核心问题是：代码可以正常运行，但复制数据时始终覆盖目标工作表（Data_Final）的第1行，没有按照预期向下逐行追加数据。你的需求是根据GroupID工作表中获取的county数量遍历数据，当计划代码和期限日期匹配时，将Data_No Formulas工作表的匹配行按指定county数量复制到目标工作表。

问题根源分析 #

原代码的几个关键逻辑错误导致了覆盖问题：

1. 写入位置错误：每次获取目标表最后一行后，直接写入该行（tsht.Range("A" & tlrow)），而不是下一行空白行，导致每次都覆盖已有内容；
2. 循环变量混乱：内部For循环中手动递增i = i + 1，破坏了循环的自然迭代逻辑；
3. 数组索引初始化不当：a变量在错误的位置初始化，导致无法正确遍历Result数组中的county值。

修正后的完整代码 #

Sub GroupID_Breakout()
 Dim dsht As Worksheet 'data sheet target
 Dim gsht As Worksheet
 Dim tsht As Worksheet
 Dim dlrow As Long
 Dim glrow As Long
 Dim tlrow As Long
 Dim SubCell As Range
 Dim rngCell As Range
 Dim Result() As String
 Dim countycount As Long
 Set dsht = ThisWorkbook.Worksheets("Data_No Formulas")
 Set gsht = ThisWorkbook.Worksheets("GroupID")
 '禁用耗时的Excel功能提升运行速度
 Application.ScreenUpdating = False
 Application.DisplayStatusBar = False
 Application.Calculation = xlCalculationManual
 '如果目标表已存在则删除
 Application.DisplayAlerts = False
 On Error Resume Next
 ThisWorkbook.Sheets("Data_Final").Delete
 On Error GoTo 0
 Application.DisplayAlerts = True
 'On Error GoTo Errhandler
 '创建新的目标工作表
 Sheets.Add(After:=Sheets("Data_No Formulas")).Name = "Data_Final"
 Set tsht = ThisWorkbook.Worksheets("Data_Final")
 '复制表头到目标表
 With dsht.Range("A2:CN2")
 tsht.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
 End With
 '获取各工作表的最后一行行号
 glrow = gsht.Cells(Rows.Count, 1).End(xlUp).Row
 dlrow = dsht.Cells(Rows.Count, 1).End(xlUp).Row
 '遍历GroupID表中的county数量列
 For Each SubCell In gsht.Range("I2:I" & glrow)
 countycount = SubCell.Value
 '拆分逗号分隔的county列表为数组
 Result() = Split(SubCell.Offset(0, -2).Value, ",")
 '遍历数据工作表的每一行数据
 For Each rngCell In dsht.Range("A3:A" & dlrow)
 a = 0
 i = 1
 '按照county数量循环复制匹配行
 For i = 1 To countycount
 '匹配计划代码和期限日期
 If SubCell.Offset(0, -4).Value = rngCell.Value And SubCell.Offset(0, -8).Value = rngCell.Offset(0, 5).Value Then
 With dsht.Range(rngCell, rngCell.Offset(0, 91))
 '获取目标表最后一行，写入下一行（避免覆盖）
 tlrow = tsht.Cells(Rows.Count, 1).End(xlUp).Row
 tsht.Range("A" & (tlrow + 1)).Resize(.Rows.Count, .Columns.Count).Value = .Value
 End With
 '为当前复制行赋值对应的county
 tsht.Range("L" & (tlrow + 1)).Value = Result(a)
 End If
 a = a + 1
 Next i
 Next rngCell
 Next SubCell
 '恢复Excel功能
 Application.ScreenUpdating = True
 Application.DisplayStatusBar = True
 Application.Calculation = xlCalculationAutomatic
 MsgBox ("Macro Complete!")
 Exit Sub
 Errhandler:
 '错误处理时恢复Excel功能
 Application.ScreenUpdating = True
 Application.DisplayStatusBar = True
 Application.Calculation = xlCalculationAutomatic
 Select Case Err.Number
 Case Else
 MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Summary"
 End Select
 End Sub

关键修复说明 #

• 避免覆盖核心修改：将写入位置从A" & tlrow改为A" & (tlrow + 1)，确保每次都写入到目标表的下一行空白行；
• 修复循环逻辑：移除了内部循环中手动递增i的代码，让For i = 1 To countycount自然控制循环次数，避免逻辑混乱；
• 正确遍历county数组：在每个数据行循环开始时初始化a，并在内部循环中递增a，实现Result数组中county值的依次赋值；
• 优化注释：添加了更清晰的注释，方便理解代码逻辑。

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