更新具有相似标头的不同表格数据

Question

我从一个源表格数据更新不同工作表中的几张表格，其中的目标表格具有相似的标题，其中目标表格具有一些额外的标题。

，我是使用下面的VBA代码，但它非常困难，如果我换了头。

 
    
 
    
 
    lastRow = Sheets("Data Sheet").Range("D" & Rows.Count).End(xlUp).Row 
 
    Sheets("Report").Range("B8:B" & lastRow).Value = Sheets("Data Sheet").Range("D8:D" & lastRow).Value 
 
    
 
    
 
    lastRow = Sheets("Data Sheet").Range("F" & Rows.Count).End(xlUp).Row 
 
    Sheets("Report").Range("C8:C" & lastRow).Value = Sheets("Data Sheet").Range("F8:F" & lastRow).Value 
 
    
 
    
 
    lastRow = Sheets("Data Sheet").Range("H" & Rows.Count).End(xlUp).Row 
 
    Sheets("Report").Range("E8:E" & lastRow).Value = Sheets("Data Sheet").Range("H8:H" & lastRow).Value 
 
    
 
    
 
    lastRow = Sheets("Data Sheet").Range("E" & Rows.Count).End(xlUp).Row 
 
    Sheets("Report").Range("F8:F" & lastRow).Value = Sheets("Data Sheet").Range("E8:E" & lastRow).Value 
 
    
 
    
 

有没有更好的方式来更新基于表头的数据？

感谢提前:)

Answer 1

最后我有我自己的灵活的代码。请告诉我，如果你再有任何其他方式感谢:)

Sub updatetbl() 
 
Application.ScreenUpdating = False 
 
Dim col As Range, col1 As Range 
 
Dim source As Worksheet, dest As Worksheet 
 
Dim i As String, j As Integer 
 
Set source = Sheets("Data") 
 
Set dest = Sheets("Report") 
 
' setting table headers as range 
 
Set col = source.Range("Data[#Headers]") 
 
Set col1 = dest.Range("Report[#Headers]") 
 

 
For Each cell In col 
 

 
    For Each cell1 In col1 
 
    i = cell.Value 
 
    If cell.Value = cell1.Value Then 
 
    source.Select 
 
    ' selecting matched table header column 
 
    Range("Data[" & i & "]").Copy 
 
    dest.Select 
 
    cell1.Offset(1, 0).Select 
 
    ' pasting the respective data under destination header 
 
    ActiveSheet.Paste 
 
    End If 
 
    Next cell1 
 
Next cell 
 
Application.ScreenUpdating = True 
 
End Sub

Answer 2

这将你在找什么，它通过源列遍历，找到目标表上列，然后粘贴在列（这可以通过粘贴简化整列，而不是查找最后一行，只是复制范围，但如果你想要的话，你可以弄清楚:)改变常量声明以适应你的情况。

Const SourceSheetName = "Sheet28" 
Const DestinationSheetName = "Sheet29" 
Const HeaderRow = 1 

Dim wss As Worksheet 
Dim wsd As Worksheet 

Sub CopyByHeader() 
    Set wss = Sheets(SourceSheetName) 
    Set wsd = Sheets(DestinationSheetName) 
    SourceColCount = wss.Cells(HeaderRow, 1).End(xlToRight).Column 
    DestColCount = wsd.Cells(HeaderRow, 1).End(xlToRight).Column 
    wsd.Rows("2:1000000").Clear 
    For SourceCol = 1 To SourceColCount 
     HeaderText = wss.Cells(HeaderRow, SourceCol) 
     DestCol = 1 
     Do Until wsd.Cells(HeaderRow, DestCol) = HeaderText 
      DestCol = DestCol + 1 
      If DestCol > DestColCount Then 
       MsgBox "Can't find the header " & HeaderText & " in the destination sheet!", vbCritical, "Ahh Nuts!" 
       Exit Sub 
      End If 
     Loop 
     SourceLastRow = wss.Cells(1000000, SourceCol).End(xlUp).Row 
     wss.Range(wss.Cells(HeaderRow + 1, SourceCol), wss.Cells(SourceLastRow, SourceCol)).Copy wsd.Cells(HeaderRow + 1, DestCol) 
    Next SourceCol 
End Sub