使用VBA复制和粘贴到新表行

Question

我想弄清楚这一点，我希望你能提供帮助

基本上我有表格和数据表。我希望将表单中的信息复制到数据表中Table1中的新空白行，

我已设法达到以下目的，但这导致每次都写入数据（而不是新行）。

Sub Macro1()
    Sheets("Form").Select
    Range("G5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Data").Select
    Range("Table1[[#Headers],[ID]]").Select
    Selection.End(xlDown).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Form").Select
    Range("D3").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Data").Select
    Range("Table1[[#Headers],[Contact Date]]").Select
    Selection.End(xlDown).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Form").Select
    Range("D4").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Data").Select
    Range("Table1[[#Headers],[Channel]]").Select
    Selection.End(xlDown).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Form").Select
    Range("D5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Data").Select
    Range("Table1[[#Headers],[Agent Name]]").Select
    Selection.End(xlDown).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Form").Select
    Range("D6").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Data").Select
    Range("Table1[[#Headers],[Contact ID]]").Select
    Selection.End(xlDown).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Form").Select
    Range("G3").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Data").Select
    Range("Table1[[#Headers],[Scored by]]").Select
    Selection.End(xlDown).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Form").Select
    Range("G4").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Data").Select
    Range("Table1[[#Headers],[Team Leader]]").Select
    Selection.End(xlDown).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

我意识到这似乎是一个简单的问题，但我正在努力解决这个问题。

仅供参考 - 此表格中将有29列，所以如果我想做些什么来使这个更干净，请告诉我

Answer 1

这是一种更简化的方法：

编辑 - 更新以添加“配置”数组以减少重复

Sub Transfer()

    Dim config, itm, arr
    Dim rw As Range, listCols As ListColumns
    Dim shtForm As Worksheet

    Set shtForm = Worksheets("Form") '<< data source

    With Sheets("Data").ListObjects("Table1")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With

    'array of strings with pairs of "[colname]<>[range address]"
    config = Array("ID<>G5", "Contact Date<>D3", "Channel<>D4")

    'loop over each item in the config array and transfer the value to the
    '  appropriate column
    For Each itm In config
        arr = Split(itm, "<>") ' split to colname and cell address
        rw.Cells(listCols(arr(0)).Index).Value = shtForm.Range(arr(1)).Value
    Next itm

End Sub

无需复制/粘贴/选择/激活。