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

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

使用VBA复制并粘贴到新的表格行中

1 个答案: