匹配列标题并合并工作表

Question

我有一个 excel 工作簿，里面有几张包含数据的工作表，但它们的列标题顺序不同。我还有一个名为"模板"的工作表，其中包含列名称，我需要合并所有工作表并将它们放入模板中。

Ex- 
Sheet 1 = Name DOB Age
Sam   1/2 22
Pat 22/6  25
Sheet 2 = DOB Age Name
5/6 21 Peter
Sheet 3 = Name
Ben
Sheet 4 = Age
27/9
Template = Name Age DOB 
Sam   22 1/2 
Pat   25 22/6  
Peter 21  5/6
Ben    0   0
0     0   27/9

所以模板应该在另一个工作表中的所有数据下连接一个，在相应工作表中不存在列的地方保留 0。

下面的代码为 1 个工作表正确执行此操作，但是当我创建一个包含所有工作表的外观时，它会覆盖数据。

Sub CopyHeaders()
Dim header As Range, headers As Range
Dim ws2 As Worksheet
Dim Template As Worksheet
Dim cell As Range
For Each ws2 In ActiveWorkbook.Worksheets
If IsError(Application.Match(ws2.Name, _
Array("Template", "Sheet1"), 0)) Then
Set Rng = ws2.UsedRange
For Each cell In Rng
If cell.Value = "" Then cell.Value = "0"
Next
Set headers = ws2.Range("A1:Z1")
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("Template").Cells(2, GetHeaderColumn(header.Value)).End(xlDown).End(xlUp).Offset(1, 0)
End If
Next
End If
Next
End Sub
Function GetHeaderColumn(header As String) As Integer
Dim headers As Range
Set headers = Worksheets("Template").Range("A1:Z1")
GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function

我的错误尤其在

Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("Template").Cells(2, GetHeaderColumn(header.Value)).End(xlDown).End(xlUp).Offset(1, 0)

需要帮助！

Answer 1

您需要将违规行中Cells(2, GetHeaderColumn(header.Value))2更改为可能Worksheets("Template").Rows.Count的大内容(这意味着您也可以删除.End(xlDown))。

如果您已经在底部(如第一个副本的情况)，您目前拥有的.End(xlDown).End(xlUp)会找到连续范围的底部，但如果您在该范围内的其他任何地方(因为第 2 行将用于任何进一步的副本)，因此您将开始覆盖。