Transposing Data from one workbook to another depending on column heading

Question

I have code below which transposes column values from one particular workbook (Activeworkbook - columns O,AH and I) over to another workbook ("loader file.xls" - columns A,B,C). It works perfectly for my needs

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

What I would like to do is to go one step further, I typically have to sort the data to the correct column in order to transpose it over to the loader file. What I would like to do is move the columns data over depending on the title of the column heading ("market Code, "ID", "C Code"). See the idea below...

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

The code above does not obviously work, i've tried a couple of different tactics to no avail. If anyone could help me out that would be great. Thanks

Answer 1

If you recalculate nextCell for each column, instead of using the same value for all of them, there's a chance you'll end up with mis-aligned data if any of your columns have blanks at the end.

You can reference the source table columns using ListColumns(columnName) so something like this should work (untested):

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

Answer 2

Write rearranged listobject columns to target

This approach uses

• a rather unknown feature of Application.Match() to get all column numbers of individual headers at once by a comparison of two arrays (assuming existing headers, otherwise it would need extra error handling) as well as
• the advanced feature of Application.Index() to rearrange the whole listbox data set based on the found numeric column values (whereas row values are taken completely and in unchanged order).

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

Example code

Though there are some undeclared worksheet references in OP, this should work & solve your question

'[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

Related link

• Some pecularities of the Application.Index() function