根据列标题将数据从一个工作簿转移到另一个工作簿

Question

下面的代码将列值从一个特定工作簿（Activeworkbook - 列 O、AH 和 I）转置到另一个工作簿（“loader file.xls” - 列 A、B、C）。它非常适合我的需求

Sub PullTrackerInfo()
'Pull info from respective column into correct column on loader file

Dim wb_mth As Workbook, wb_charges As Workbook, mapFromColumn As Variant, mapToColumn As Variant
    Dim lastCell As Integer, i As Integer, nextCell As Integer, arrCopy As Variant
Set wb_mth = ActiveWorkbook
Set wb_charges = Workbooks("loader file.xls")
    

    mapFromColumn = Array("O", "AH", "I")
    mapToColumn = Array("A", "B", "C")

        For i = 0 To UBound(mapFromColumn)

            With wb_mth.Sheets(1)

                lastCell = w.Sheets("owssvr").ListObjects("Table_owssvr").Range.Rows.Count
                arrCopy = .Range(mapFromColumn(i) & 2 & ":" & mapFromColumn(i) & lastCell)

            End With

            With wb_charges.Worksheets(1)

                nextCell = .Range(mapToColumn(i) & .Rows.Count).End(xlUp).Row + 1
                .Range(mapToColumn(i) & nextCell).Resize(UBound(arrCopy), UBound(arrCopy, 2)).Value = arrCopy

            End With
        Next i

End Sub

我想做的是更进一步，我通常必须将数据排序到正确的列，以便将其转置到加载程序文件。我想做的是根据列标题的标题（“市场代码”、“ID”、“C 代码”）移动列数据。请参阅下面的想法...

mapFromColumn = Array("Market Code", "ID", "C Code",
    mapToColumn = Array("A", "B", "C")

        For i = 0 To UBound(mapFromColumn)

            With wb_mth.Sheets(1)

                lastCell = w.Sheets("owssvr").ListObjects("Table_owssvr").Range.Rows.Count
                arrCopy = .Range(mapFromColumn(i) & 2 & ":" & mapFromColumn(i) & lastCell)

            End With

            With wb_charges.Worksheets(1)

                nextCell = .Range(mapToColumn(i) & .Rows.Count).End(xlUp).Row + 1
                .Range(mapToColumn(i) & nextCell).Resize(UBound(arrCopy), UBound(arrCopy, 2)).Value = arrCopy

            End With
        Next i

End Sub

上面的代码显然不起作用，我尝试了几种不同的策略都无济于事。如果有人可以帮助我，那就太好了。谢谢

Answer 1

将重新排列的 listobject 列写入目标

这种方法使用

• Application.Match() 的一个相当未知的功能是通过比较两个数组一次获取单个标题的所有列号（假设现有标题，否则需要额外的错误处理）以及
• Application.Index() 的高级功能可以根据找到的数字列值重新排列整个列表框数据集（而行值是完全采用顺序不变）.

Function getCols(individualHeaders, myTable As ListObject)
'Note: assumes existing header names & listobject start in column A
    'get all headers of list object
    Dim allHeaders
    allHeaders = Application.Transpose(myTable.HeaderRowRange.Value2)
    'get column numbers of found headers
    Dim cols
    cols = Application.Match(individualHeaders, allHeaders, 0)  ' 1-based
    ReDim Preserve cols(0 To UBound(cols) - 1)                  ' optional zero-base redim
    'return found numeric results
    getCols = cols
End Function

示例代码

虽然 OP 中有一些未声明的工作表引用，但这应该可以解决您的问题

'[0]set listobject to memory
    Dim lob As ListObject
    Set lob = w.Sheets("owssvr").ListObjects("Table_owssvr")
'[1]get column numbers
    Dim mapFromColumn As Variant
    mapFromColumn = Array("Market Code", "ID", "C Code")
    mapFromColumn = getCols(mapFromColumn, lob)
    ' Debug.Print Join(mapFromColumn, ",")
'[2]get complete set of listobject data
    Dim data As Variant
    data = lob.DataBodyRange.Value2
'[3]limit data set to chosen columns in subsequent order
    data = Application.Index(data, Evaluate("row(1:" & UBound(data) & ")"), mapFromColumn)
'[4]write data to target
    Dim wb_charges As Workbook
    Set wb_charges = Workbooks("loader file.xls")
    With wb_charges.Worksheets(1)
        Dim nextCell As Long
        nextCell = .Range("A" & .Rows.Count).End(xlUp).Row + 1 
        .Range("A" & nextCell).Resize(UBound(data), UBound(data, 2)).Value = data
    End With

相关链接

• Some pecularities of the Application.Index() function

Answer 2

如果您为每列重新计算 nextCell，而不是对所有列使用相同的值，那么如果您的任何列末尾有空白，您最终可能会得到未对齐的数据。

您可以使用ListColumns(columnName) 引用源表列，这样应该可以工作（未经测试）：

Dim lo As ListObject, wsDest As Worksheet, numRows As Long

'...
'...

Set wsDest = wb_charges.Worksheets(1)
Set lo = w.Sheets("owssvr").ListObjects("Table_owssvr")
numRows = lo.DataBodyRange.Rows.Count

mapFromColumn = Array("Market Code", "ID", "C Code")
mapToColumn = Array("A", "B", "C")

'start all destinations on the same row (choose a column with no blanks in the data...)
nextcell = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1
    
For i = 0 To UBound(mapFromColumn)
    wsDest.Cells(nextcell, mapToColumn(i)).Resize(numRows).Value = _
        lo.ListColumns(mapFromColumn(i)).DataBodyRange.Value
Next i