Question

Currently I have spreadsheets coming in that are formatted incorrectly. Our client sent out to his suppliers an old spreadsheet where columns are laid out differently than what they are currently setup as. Normally we would tell them to correct it, but some of these spreadsheets have over 220k rows and 33 columns. They’re updating it for the future, but asking them to have their clients redo their tables is a no-go. I’ve written a script that will copy a column, and place it into the corresponding static column in another workbook. This works okay but I feel there is more that could be done.

Name of open workbook copying from varies.

Name of workbook copied to: C:\User\(Name)\UCOR\Catalogs\PSX-Toolset v1.503-EN.xls

What I would like is help writing a macro that will do the following from open workbook:

1.) Select an entire column minus Row 1 to the first blank row. – This goes from B to AH

2.) Paste that column into PSX-Toolset workbook, worksheet name “Item Data” – Static Assigned Columns

3.) Perform a Save As on PSX-Toolset as (Catalog-PSX-<Workbook Copied From>.xls)

Lastly, I’d like to know if it’s possible to do the above, but mapping heading cells. Unfortunately the cell names are not identical.

Answer 1

Untested:

Sub MapAndCopyColumns()

Dim i As Integer, rng As Range
Dim shtSrc As Worksheet, wbDest As Workbook
Dim shtDest As Worksheet
Dim iNew

    Set shtSrc = ActiveSheet
    Set wbDest = Workbooks.Open("C:\User\(Name)\UCOR\Catalogs\PSX-Toolset v1.503-EN.xls")
    Set shtDest = wbDest.Sheets("Item Data")

    For i = 2 To 34
        Set rng = shtSrc.Cells(2, i)
        If rng.Value <> "" Then
            If rng.Offset(1, 0).Value <> "" Then
                Set rng = Range(rng, rng.End(xlDown))
            End If
            'map old position >> new position
            '  mapping table has 2 columns of numbers: "old" and "new"
            iNew = Application.VLookup(i, _
                ThisWorkbook.Sheets("Mapping").Range("A2:B40"), 2, False)
            If Not IsError(iNew) Then
                'copy if the column has an entry in the mapping table
                rng.Copy shtDest.Cells(2, iNew)
            End If
        End If
    Next i

    wbDest.SaveAs "C:\wheretosaveto\Catalog-PSX-" & shtSrc.Parent.Name

End Sub