Question

我正在制作2张具有常用字段的Excel表格。我将需要使用VBA基于列标题和现有数据下方的sheet2中粘贴数据。例如：

表1：

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

表2：

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 以及其他匹配功能。

使用VBA基于列标题追加新行

1 个答案: