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

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

这将执行您要查找的内容，它遍历源列，在目标工作表上找到该列，然后将列粘贴（可以通过粘贴整个列而不是查找最后一行来简化此操作只是复制范围，但你可以想出来，如果你想:)改变常量声明，以适应你的情况。

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

Answer 2

最后我得到了自己灵活的代码。如果您有任何其他方式再次感谢请告诉我：）

＆＃13;

＆＃13;

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

＆＃13;

＆＃13;

＆＃13;