我有一个包含11个工作表的工作簿。每个工作簿都将第1行作为列标题。某些列标题对所有工作表都是通用的，但它们的顺序并不一致。
Sheet1是源工作表。我想根据列标题将数据从工作表1传输到所有其他工作表。我试图修改一个代码，但它只适用于1个目标工作表。
Sub AG()
Dim ws_B As Worksheet
Dim HeaderRow_A As Long
Dim HeaderLastColumn_A As Long
Dim TableColStart_A As Long
Dim NameList_A As Object
Dim SourceDataStart As Long
Dim SourceLastRow As Long
Dim Source As Variant
Dim rowTarget As Long
Dim iHighestUsedRow&
Dim LastRow As Long
Dim i As Long
Dim ws_B_lastCol As Long
Dim NextEntryline As Long
Dim SourceCol_A As Long
Set ws_A = Worksheets("Sheet1")
Set ws_B = Worksheets("Sheet2")
Set NameList_A = CreateObject("Scripting.Dictionary")
With ws_A
SourceDataStart = 2
HeaderRow_A = 1
TableColStart_A = 1
HeaderLastColumn_A = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column
iHighestUsedRow = 0
For i = TableColStart_A To HeaderLastColumn_A
If Not NameList_A.Exists(UCase(.Cells(HeaderRow_A, i).Value)) Then
NameList_A.Add UCase(.Cells(HeaderRow_A, i).Value), i
End If
Next i
End With
With ws_B
ws_B_lastCol = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column
For i = 1 To ws_B_lastCol
SourceLastRow = .Cells(Rows.Count, i).End(xlUp).Row
If SourceLastRow > iHighestUsedRow Then
iHighestUsedRow = SourceLastRow
End If
Next i
End With
With ws_B
For i = 1 To ws_B_lastCol
SourceCol_A = NameList_A(UCase(.Cells(1, i).Value))
If SourceCol_A <> 0 Then
SourceLastRow = ws_A.Cells(Rows.Count, SourceCol_A).End(xlUp).Row
If SourceLastRow > 1 Then
Set Source = ws_A.Range(ws_A.Cells(SourceDataStart, SourceCol_A), ws_A.Cells(SourceLastRow, SourceCol_A))
NextEntryline = iHighestUsedRow + 1
.Range(.Cells(NextEntryline, i), _
.Cells(NextEntryline, i)) _
.Resize(Source.Rows.Count, Source.Columns.Count).Cells.Value = Source.Cells.Value
End If
End If
Next i
End With
End Sub
请尝试下一个更新的代码：
Sub AG()
Dim ws_B As Worksheet, HeaderRow_A As Long, HeaderLastColumn_A As Long, TableColStart_A As Long
Dim NameList_A As Object, SourceDataStart As Long, SourceLastRow As Long, Source As Variant, LastRow As Long
Dim i As Long, ws_B_lastCol As Long, NextEntryline As Long, SourceCol_A As Long, iHighestUsedRow As Long
Dim ws_A As Worksheet
Set ws_A = Worksheets("Sheet1")
'Set ws_B = Worksheets("Sheet2")
Set NameList_A = CreateObject("Scripting.Dictionary")
With ws_A
SourceDataStart = 2
HeaderRow_A = 1
TableColStart_A = 1
HeaderLastColumn_A = .cells(HeaderRow_A, Columns.count).End(xlToLeft).Column
'iHighestUsedRow = 0
For i = TableColStart_A To HeaderLastColumn_A
If Not NameList_A.Exists(UCase(.cells(HeaderRow_A, i).Value)) Then
NameList_A.Add UCase(.cells(HeaderRow_A, i).Value), i
End If
Next i
End With
For Each ws_B In ActiveWorkbook.Worksheets
If ws_B.name <> ws_A.name Then 'exclude the sheet where to copy from
iHighestUsedRow = 0
With ws_B
ws_B_lastCol = .cells(HeaderRow_A, Columns.count).End(xlToLeft).Column
For i = 1 To ws_B_lastCol
SourceLastRow = .cells(rows.count, i).End(xlUp).row
If SourceLastRow > iHighestUsedRow Then
iHighestUsedRow = SourceLastRow
End If
Next i
For i = 1 To ws_B_lastCol
SourceCol_A = NameList_A(UCase(.cells(1, i).Value))
If SourceCol_A <> 0 Then
SourceLastRow = ws_A.cells(rows.count, SourceCol_A).End(xlUp).row
If SourceLastRow > 1 Then
Set Source = ws_A.Range(ws_A.cells(SourceDataStart, SourceCol_A), ws_A.cells(SourceLastRow, SourceCol_A))
NextEntryline = iHighestUsedRow + 1
.Range(.cells(NextEntryline, i), _
.cells(NextEntryline, i)) _
.Resize(Source.rows.count, Source.Columns.count).cells.Value = Source.cells.Value
End If
End If
Next i
End With
End If
Next ws_B
End Sub
复制到具有不同排列标题的多个工作表
Option Explicit
Sub CopyToMultipleWorksheets()
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source worksheet ('sws').
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
' Declare variables.
Dim sdrg As Range ' Source Data Range (no headers)
Dim shData() As Variant ' Source Header Array
Dim srCount As Long ' Number of Rows in the Source Data Range
Dim scCount As Long ' Number of Columns in the Source Data/Header Range
' Reference the source range (has headers).
With sws.Range("A1").CurrentRegion
' Write the values from the first row to a 2D one-based one-row array,
' the source header array ('shdata').
shData = .Rows(1).Value
' Write the number of rows of the source data range (no headers)
' to a variable ('srCount').
srCount = .Rows.Count - 1
' Write the number of columns to a variable ('scCount').
scCount = .Columns.Count
' Reference the source data range ('sdrg').
Set sdrg = .Resize(srCount).Offset(1)
End With
' Create and reference a new dictionary object ('dict').
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' case-insensitive i.e. 'A = a'
' Declare variables.
Dim sc As Long ' Current Source Column
' Write the headers to the 'keys' and the values from the corresponding
' source data range columns to the associated 'items' of the dictionary.
For sc = 1 To scCount
dict(CStr(shData(1, sc))) = sdrg.Columns(sc).Value
Next sc
' Declare variables.
Dim dws As Worksheet ' Destination Worksheet
Dim drg As Range ' Destination Range
Dim dhData() As Variant ' Destination Header Array
Dim dcCount As Long ' Number of Columns in the Destination Data/Header Range
Dim dc As Long ' Destination Column
Dim dHeader As String ' Destination Header
' Loop through worksheets...
For Each dws In wb.Worksheets
If Not dws Is sws Then ' it's not the source worksheet
' Reference the (currently occupied) destination range.
With dws.Range("A1").CurrentRegion
' Write the values from the first row to a 2D one-based one-row
' array, the destination header array ('dhdata').
dhData = .Rows(1).Value
' Write the number of columns to a variable ('dcCount').
dcCount = .Columns.Count
' Reference the range that will be written to,
' the destination range ('drg').
Set drg = .Resize(srCount).Offset(.Rows.Count)
End With
' Loop through the columns...
For dc = 1 To dcCount
' Write the current header to a string variable ('dHeader').
dHeader = CStr(dhData(1, dc))
' Check if the destination header exists in the dictionary.
If dict.Exists(dHeader) Then ' the header exists
drg.Columns(dc).Value = dict(dHeader) ' write
'Else ' the header doesn't exist; do nothing
End If
Next dc
'Else ' it's the source worksheet; do nothing
End If
Next dws
' Save the workbook.
'wb.Save
' Inform.
MsgBox "Data copied.", vbInformation
End Sub