Копирование и вставка в новую строку таблицы с использованием VBA - PullRequest
Новая
       33

Копирование и вставка в новую строку таблицы с использованием VBA

0 голосов
/ 07 сентября 2018

Я пытаюсь понять это и надеюсь, что вы можете помочь

В основном у меня есть форма и паспорт. Я хочу скопировать информацию в форме в новую пустую строку в Таблице 1 на листе данных,

Мне удалось добраться до следующего, но это приводит к тому, что данные перезаписываются каждый раз (вместо новой строки). 

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 столбцов, поэтому, если мне нужно что-то сделать, чтобы сделать это чище, пожалуйста, дайте мне знать

1 Ответ

0 голосов
/ 07 сентября 2018

Вот более упрощенный подход к этому:

РЕДАКТИРОВАТЬ - обновлен для добавления массива "config" для уменьшения повторения 

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

Не требуется копировать / вставлять / выбирать / активировать.

...