VBAを使用して列ヘッダーに基づいて新しい行を追加する

Question

私は共通のフィールドを持つ2つのExcelシートを作成しています。 VBAを使用して、列ヘッダーと既存データの下にあるsheet2にデータを貼り付ける必要があります。例：

TABLE1：

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 

私はBを発見しました私はインターネットでelowコードが、私はこれを調整する必要があります。列全体が貼り付けられ、新しい行が追加されません。

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と追加マッチ機能に見えるかもしれません。