使用VBA根据列标头追加新行

Question

我正在工作的2个Excel表有共同的领域。我将需要粘贴数据sheet2基于列标题和下面的现有数据使用VBA。如:

table1:

ID Name  Custcode CustName
1  Aryan  0020    Aryan Ent
2  SUman  0030    Suman Ent
3  Ramesh 0040    Ramesh Ent

表二:

ID Name  Alias Name Custcode CustName   Prodcode Proddesc
1  Aryan  Alex      0020     Aryan Ent  xx001    Books 
2  SUman  Sandy     0030     Suman Ent  xx002    online 

目标表:

ID Name  Alias Name Custcode CustName   Prodcode Proddesc
1  Aryan  Alex      0020     Aryan Ent  xx001    Books 
2  SUman  Sandy     0030     Suman Ent  xx002    online 
3  Ramesh           0040     Ramesh Ent

我在互联网上找到了下面的代码，但我需要对此进行调整。它正在粘贴整个列，而不追加新行:

Sub copycolumns()
    Dim i As Integer, searchedcolumn As Integer, searchheader As Object
    For i = 1 To 83
        Set searchheader = Sheets("Temp").Cells(1, i)
        searchedcolumn = 0
        On Error Resume Next
        searchedcolumn = Sheets("Malaysia Live data").Rows(1).Find(what:=searchheader.Value, lookat:=xlWhole).Column
        On Error GoTo 0
        If searchedcolumn <> 0 Then
           Sheets("Malaysia Live data").Columns(searchedcolumn).Copy Destination:=searchheader
        End If
        Next i
   End Sub

Answer 1

一个非常基本的程序，位置是硬编码的。

Sub test_1()
Dim a As Variant
Dim b As Variant
a = 2
Worksheets("Target Table").Activate
While Worksheets("Table 1").Cells(a, 1) <> vbNullString
    Cells(a, 1) = Worksheets("Table 1").Cells(a, 1)
    Cells(a, 2) = Worksheets("Table 1").Cells(a, 2)
    Cells(a, 5) = Worksheets("Table 1").Cells(a, 3)
    Cells(a, 6) = Worksheets("Table 1").Cells(a, 4)
    b = WorksheetFunction.Match(Cells(a, 2), Worksheets("Table 2").Range("B:B"))
    If Not IsError(b) Then
        Cells(a, 3) = Worksheets("Table 2").Cells(b, 3)
        Cells(a, 8) = Worksheets("Table 2").Cells(b, 8)
        Cells(a, 7) = Worksheets("Table 2").Cells(b, 7)
    End If
    b = vbNullString
    a = a + 1
Wend

End Sub

您可以查看HLookUp和其他Match函数。