VBA循环复制列范围错误 同表头列数据被覆盖无法逐行追加

代码出现覆盖问题是三个逻辑错误导致的：

• 复制源表列时把表头行也纳入了复制范围，每次粘贴都会重复写入表头
• 计算粘贴目标区域时，错误使用源表列的行数作为输出表的结束行坐标，没有基于输出表现有内容的最后一行计算粘贴位置
• 所有Cells、Range调用没有显式指定所属工作表，VBA会默认读取当前激活工作表的单元格坐标，跨表循环时很容易出现引用错位。

替换核心循环逻辑即可，修复后的完整代码如下：

Dim ws As Worksheet
Dim max_ws As Worksheet
Dim output_ws As Worksheet
Dim max_ws_header As Range
Dim output_ws_header As Range
Dim cc As Long
Dim max_cc As Long
Dim output_header_counter As Long
Dim ws_header_counter As Long
Dim output_header_name As String
Dim ws_header_name As String


Application.DisplayAlerts = False
On Error Resume Next ' 增加容错，避免待删除工作表不存在时报错中断
Sheets("indice").Delete
Sheets("aneca").Delete
On Error GoTo 0
Application.DisplayAlerts = True

For Each ws In Worksheets
    ws.Rows(1).EntireRow.Delete
    ws.Columns.Hidden = False
Next ws

max_cc = 0

For Each ws In Worksheets
    cc = last_column_index(ws, 1)
    If cc > max_cc Then
        max_cc = cc
        Set max_ws = ws
    End If
Next ws

' 提前删除已存在的Output表，避免重名报错
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Output").Delete
On Error GoTo 0
Application.DisplayAlerts = True

Sheets.Add.Name = "Output"
Set output_ws = Sheets("Output")

Set max_ws_header = max_ws.Range(max_ws.Cells(1, 1), max_ws.Cells(1, max_cc))
Set output_ws_header = output_ws.Range(output_ws.Cells(1, 1), output_ws.Cells(1, max_cc))

max_ws_header.Copy output_ws_header

For Each ws In Worksheets
    If ws.Name <> "Output" Then
        Dim wsColCount As Long
        wsColCount = last_column_index(ws, 1)
        For ws_header_counter = 1 To wsColCount
            ws_header_name = Trim(ws.Cells(1, ws_header_counter).Value)
            If Len(ws_header_name) = 0 Then GoTo NextWsCol ' 空表头直接跳过
            
            For output_header_counter = 1 To max_cc
                output_header_name = Trim(output_ws.Cells(1, output_header_counter).Value)
                If ws_header_name = output_header_name Then
                    Dim wsLastRow As Long
                    wsLastRow = last_row_index(ws, ws_header_counter)
                    If wsLastRow < 2 Then GoTo NextWsCol ' 无有效数据时跳过
                    
                    Dim outputStartRow As Long
                    outputStartRow = last_row_index(output_ws, output_header_counter) + 1
                    
                    ' 显式指定所有单元格所属工作表，复制时跳过表头行
                    ws.Range(ws.Cells(2, ws_header_counter), ws.Cells(wsLastRow, ws_header_counter)).Copy _
                        output_ws.Cells(outputStartRow, output_header_counter)
                    Exit For
                End If
            Next output_header_counter
NextWsCol:
        Next ws_header_counter
    End If
Next ws

原自定义函数没有限定行、列总数的所属工作表，也需要同步修正，避免跨表调用时计算错误：

Function last_row_index(target_worksheet As Worksheet, target_column_index As Long) As Long
    With target_worksheet
        last_row_index = .Cells(.Rows.Count, target_column_index).End(xlUp).Row
    End With
End Function

Function last_column_index(target_worksheet As Worksheet, target_row_index As Long) As Long
    With target_worksheet
        last_column_index = .Cells(target_row_index, .Columns.Count).End(xlToLeft).Column
    End With
End Function

• 复制源表数据时从第2行开始，跳过已经写入输出表的表头行
• 粘贴时只需要指定目标区域的起始单元格，Excel会自动适配复制内容的范围，不需要手动计算结束行，从根源避免结束行计算错误
• 所有单元格、范围调用都显式绑定所属工作表对象，不会出现跨表引用错位
• 增加了空表头、空数据列的跳过逻辑，加了删除工作表的容错处理，避免代码运行中断
• 表头匹配增加了去空格处理，避免表头前后存在不可见空格导致匹配失败

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