VBA跨工作表按标题复制数据：空列复制表头问题求助

问题根源 #

当Input工作表某列仅存在表头（无数据行）时，代码创建源数据范围的逻辑会错误包含表头单元格：

• .Cells(1000000, 1).End(xlUp)会定位到表头所在的第1行
• 此时Range(.Cells(2, 1), .Cells(1000000, 1).End(xlUp))等价于Range(A2, A1)，VBA会自动调整为A1:A2，导致表头被纳入数据范围，最终复制到Output的第2行位置。

解决思路 #

在创建源数据范围前，先判断源列是否存在有效数据行：

1. 检查源列最后一个非空单元格的行号是否大于1（即存在数据行）
2. 仅当存在数据时，才创建数据范围并执行复制；若没有数据，则跳过该列的复制操作（或按需清空目标列对应区域）

修改后的代码 #

Sub CopyDataSpecificHeadings()
Dim intErrCount As Integer

'Set Data/Copy Sheets
 Dim shtSource As Worksheet: Set shtSource = Sheets("Input")
 Dim shtTarget As Worksheet: Set shtTarget = Sheets("Output")

'Create Range Objects
 Dim rngSourceHeaders As Range: Set rngSourceHeaders = shtSource.Range("A1:Z1") 'Full range of the report you are looking up from

 With shtTarget
    Dim rngTargetHeaders As Range: Set rngTargetHeaders = .Range("A1:Z1") '.Cells(1, 1), .Cells(1,.Columns.Count).End(xlToLeft)) 'Or just .Range("A1:AZ1")
    Dim rngPastePoint As Range: Set rngPastePoint = .Cells(.Rows.Count, 1).End(xlUp).Offset(1) 'Shoots up from the bottom of the sheet untill it bumps into something and steps one down
 End With

Dim rngDataColumn As Range
Dim lastDataRow As Long '存储源列最后一个非空行的行号

'Process Data
 Dim cl As Range, i As Integer
 For Each cl In rngTargetHeaders ' loop through each cell in target header row

'Identify source location
 i = 0 ' reset I
On Error Resume Next ' ignore errors, these are where the value can't be found and will be tested later
    i = Application.Match(cl.Value, rngSourceHeaders, 0) 'Finds the matching column name
On Error GoTo 0 ' switch error handling back off

'Report if source location not found
 If i = 0 Then
    intErrCount = intErrCount + 1
    Debug.Print "unable to locate item [" & cl.Value & "] at " & cl.Address ' this reports to Immediate Window (Ctrl + G to view)
    GoTo nextCL
End If

'获取源列最后一个非空行的行号
lastDataRow = rngSourceHeaders.Cells(1, i).Offset(1, 0).End(xlDown).Row
'处理特殊情况：如果从第2行往下都是空的，End(xlDown)会跳到工作表最后一行，此时重新判断
If lastDataRow = shtSource.Rows.Count Then
    If IsEmpty(rngSourceHeaders.Cells(1, i).Offset(1, 0)) Then
        lastDataRow = 1 '标记为无数据行
    End If
End If

'仅当存在数据行时（lastDataRow>1），才执行复制
If lastDataRow > 1 Then
    'Create source data range object
    With rngSourceHeaders.Cells(1, i)
        Set rngDataColumn = Range(.Cells(2, 1), .Cells(lastDataRow, 1))
    End With

    'Pass to target range object
    cl.Offset(1, 0).Resize(rngDataColumn.Rows.Count, rngDataColumn.Columns.Count).Value = rngDataColumn.Value
Else
    '可选：如需清空目标列现有数据，可取消注释以下代码
    'cl.Offset(1, 0).Resize(shtTarget.Rows.Count - 1, 1).ClearContents
    Debug.Print "No data found for column [" & cl.Value & "] in Input sheet"
End If

nextCL:
Next cl
'Confirm process completion and issue any warnings
If intErrCount = 0 Then
  MsgBox "Process Completed", vbInformation
Else
MsgBox "WARNING: " & intErrCount & " issues encountered. Check VBA log for details", vbExclamation
End If
End Sub

关键修改点说明 #

• 新增lastDataRow变量，用于判断源列是否存在数据行
• 增加对End(xlDown)的特殊处理：当第2行开始全为空时，End(xlDown)会跳到工作表最后一行，此时通过判断第2行是否为空，将lastDataRow设为1（标记无数据）
• 只有当lastDataRow>1时才执行复制操作，避免将表头错误复制到目标行

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