Paste data - ranges of Listobjects in other Listob

问题:

I am using VBA to move data between tables in excel (ListObjects) And I want to avoid loops for they are too much time consuming

I have a first (origin) table called:tabl1 and a second origin table: tbl2

I have a destiny table called:tbl3 this table is empty, so databodyrange is nothing

I would like to paste data from the two origin tables tbl1 and tbl2 into tbl3

Dim tbl1 As ListObject
Dim tbl2 As ListObject
Dim tbl3 As ListObject
Set tbl1 = ThisWorkbook.Sheets(1).ListObjects("table1")
Set tbl2 = ThisWorkbook.Sheets(1).ListObjects("table2")
Set tbl3 = ThisWorkbook.Sheets(1).ListObjects("table3")

'delete the data of table 3
If Not tbl3.DataBodyRange Is Nothing Then
    tbl3.DataBodyRange.Delete
End If

'Adding a first row to avoid that databodyrange isnothing
tbl3.ListRows.Add
'this code does not work
'What I try to do is copy the range of column1 of table1 and paste it in the first 
tbl1.ListColumns(1).DataBodyRange.Copy Destination:=tbl3.ListColumns(1).DataBodyRange.Item(1).Address

I dont want to use loop (too slow) And I dont want to use ".select": too error-prone.

And of course, the data pasted in table three has to be part of the table.

In this link I posted myself (and answered) a partial solution to the problem: Excel copy data from several columns of listobject A (tableA) into one column of listobject B (tableB) one after the other

but I would really like to find a solution referring only to the name of listobjects and not to absolute positions in a sheet (otherwise moving the listobject would invalidate the solution).

Here is the problem illustrated. Be aware that I put the three tables in one sheet for clarity purposes but the tables are distributed in different sheets.

This is the desired result:

回答1:

Try this:

Dim TBL1 As ListObject
Dim TBL2 As ListObject
Dim TBL3 As ListObject

Set TBL1 = ActiveSheet.ListObjects("TBL_1")
Set TBL2 = ActiveSheet.ListObjects("TBL_2")
Set TBL3 = ActiveSheet.ListObjects("TBL_3")

Dim ZZ As Long

'we clean TBL3 only if there is data
If Range(TBL3.Name & "[" & TBL3.HeaderRowRange(1, 1).Value & "]").Cells(1, 1).Value <> "" Or _
    Range(TBL3.Name & "[" & TBL3.HeaderRowRange(1, 1).Value & "]").Count > 1 Then TBL3.DataBodyRange.Delete


Range(TBL1.Name & "[" & TBL1.HeaderRowRange(1, 1).Value & "]").Copy
Range(TBL3.Name & "[" & TBL3.HeaderRowRange(1, 1).Value & "]").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False

Range(TBL1.Name & "[" & TBL1.HeaderRowRange(1, 3).Value & "]").Copy
Range(TBL3.Name & "[" & TBL3.HeaderRowRange(1, 3).Value & "]").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False

Range(TBL2.Name & "[" & TBL2.HeaderRowRange(1, 1).Value & "]").Copy

Range(TBL3.Name & "[" & TBL3.HeaderRowRange(1, 1).Value & "]").End(xlDown).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False

Range(TBL2.Name & "[" & TBL2.HeaderRowRange(1, 3).Value & "]").Copy

Range(TBL3.Name & "[" & TBL3.HeaderRowRange(1, 3).Value & "]").End(xlDown).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False

'we clean blanks
For ZZ = TBL3.DataBodyRange.Rows.Count To 1 Step -1
    If TBL3.DataBodyRange.Cells(ZZ, 1).Value = "" Then TBL3.ListRows(ZZ).Delete
Next ZZ


Set TBL1 = Nothing
Set TBL2 = Nothing
Set TBL3 = Nothing

The code pastes all data in Column 1 and 3 of Tbl1 and Tbl2 into column 1 and 3 of Tbl3.

After pasting, it checks if there is any blank, and if true, then it deletes that row of the table.

I tried with this:

And after applying code, I get this:

Please, note that the code also deletes ALL data in TBL3 before pasting.

Hope you can adap this to your needs.