更新具有相似標頭的不同表格數據

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