使用 vba 将表从一个工作簿复制到另一个工作簿

Question

我在 wb1 中有一个表，我希望能够复制该表，然后将其粘贴到 wb2 中的另一张表，但我想让它更加动态，这样我的代码就不再只是选择表，而是遍历列名称使用名称复制每一列，然后将其粘贴到另一个工作表中。这是我的代码

'get column names from table "Table1"
Dim TblHeadings() As String
Dim z As Variant
Dim i As Integer
i = -1
For Each z In Rows(2).Cells
    If z.Value = "" Then Exit For
    i = i + 1
    ReDim Preserve TblHeadings(i) As String
    TblHeadings(i) = z.Value
Next z

'copy columns with headers from previous loop
Dim a As Range, w
With wb1.Sheets("Sheet1").ListObjects("Table1")
    For Each a In z
        If w Is Nothing Then
            Set w = .ListColumns(a).Range
        Else
            Set w = Union(w, .ListColumns(a).Range)
        End If
    Next
End With

w.Select
Selection.Copy

表 1 从 B2 开始。如何修改 Rows(2).Cells 以从 B2 开始？目前它从 B1 开始，它是空的，所以我的循环退出？这段代码的其余部分看起来还好吗？

Answer 1

我可能会做这样的事情。 列标题数组只是开销，除非您有大量列要复制。

Sub Tester()

    Dim wbSrc As Workbook, wbDest As Workbook, loSource As ListObject, wsDest As Worksheet
    Dim lc As ListColumn, destHeaders As Range, c As Range
    
    Set wbSrc = ThisWorkbook            'for example
    Set wbDest = Workbooks("Text.xlsx") 'for example
    
    Set loSource = wbSrc.Worksheets("Sheet1").ListObjects("Table1") 'source table
    
    'destination headers....
    Set destHeaders = wbDest.Worksheets("Sheet2").Rows(2).SpecialCells(xlCellTypeConstants)
    Application.ScreenUpdating = False
    For Each c In destHeaders.Cells
        Set lc = Nothing     'reset
        On Error Resume Next 'ignore if no matching column
        Set lc = loSource.ListColumns(c.Value)
        On Error GoTo 0      'stop ignoring error
        If Not lc Is Nothing Then  'got a match
            lc.DataBodyRange.Copy c.Offset(1)
        Else
            'flag no match
            Debug.Print "No list column for '" & c.Value & "'"
        End If
    Next c
    
End Sub