Copying and Pasting into a new Table Row using VBA

Question

I am trying to figure this out and I am hoping you can help

Basically I have Form and Data Sheet. I am looking to copy the information in the form into a new blank row within Table1 on the data sheet,

I have managed to get as far as the following but this causes the data to be over written each time, (rather than a a new row).

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

I realise this may seem like a simple question but I am struggling to work this out.

FYI - There will be 29 Columns to this table so If I should be doing something to make this cleaner, please let me know

change all `Selection.End(xlDown).Select` to `Selection.End(xlDown).offset(1, 0).Select`. — , Sep 07 '18 at 06:52
And I recommend to read [How to avoid using Select in Excel VBA](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba) to get rid of all these ugly `.Select` statements that you don't need. Using `.Select` and `Selection` should be avoided where ever possible. — Pᴇʜ, Sep 07 '18 at 07:16

Tim Williams · Answer 1 · 2018-09-07T17:22:40.923

Here's a more streamlined way to approach this:

EDIT - updated to add "config" array to reduce repetition

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

No copy/paste/select/activate required.

Copying and Pasting into a new Table Row using VBA

1 Answers1