VBA choose columns and paste to new sheet

I would like to find 14 columns by header in Shipper sheet and paste to Reduced Data sheet.
I can do this one by one, but really need to work this into an array I think for better function.
Can someone help??

The need to be pasted in this order:
Service Type      
Package Type      
Zone      
Shipment Rated Weight      
Original Weight      
Pieces in Shipment      
Index      
Shipper State      
Shipper Country      
Recipient State      
Recipient Country Code      
Dimmed Height      
Dimmed Width      
Dimmed Length



Sub CopyColumnfromShipping()
'Find "Name" in Row 1
  With Sheets("Shipping").Rows(1)
   Set t = .Find("Service Type", lookat:=xlPart)
'If found, copy the column to Sheet 2, Column A
'If not found, present a message
     If Not t Is Nothing Then
        Columns(t.Column).EntireColumn.Copy _
          Destination:=Sheets("Reduced Data").Range("A1")
       Else: MsgBox "Needed Data not found in Shipping detail"
     End If
  End With
End Sub

Open in new window

Rerate-v5.4.sample.xlsm
Euro5Asked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Try this.....
The code is placed on Standard Module named as CopyColumnsToReducedData.
I have also inserted a button on Reduced_data sheet, you may click that button to run the code.

Sub CopySpecificColumnsToReducedDataSheet()
Dim sws As Worksheet, dws As Worksheet
Dim col1, col2, col3, col4, col5, col6, col7, col8, col9, col10, col11, col12, col13, col14

Application.ScreenUpdating = False
Set sws = Sheets("Shipping")
Set dws = Sheets("Reduced_data")

col1 = "Service Type"
col2 = "Package Type"
col3 = "Zone"
col4 = "Shipment Rated Weight"
col5 = "Original Weight"
col6 = "Pieces in Shipment"
col7 = "Index"
col8 = "Shipper State"
col9 = "Shipper Country"
col10 = "Recipient State"
col11 = "Recipient Country Code"
col12 = "Dimmed Height"
col13 = "Dimmed Width"
col14 = "Dimmed Length"

dws.Cells.Clear

If Application.CountIf(sws.Rows(1), col1) > 0 Then
    col1 = Application.Match(col1, sws.Rows(1), 0)
    sws.Columns(col1).Copy dws.Range("A1")
    Application.CutCopyMode = 0
End If

If Application.CountIf(sws.Rows(1), col2) > 0 Then
    col2 = Application.Match(col2, sws.Rows(1), 0)
    sws.Columns(col2).Copy dws.Range("B1")
    Application.CutCopyMode = 0
End If

If Application.CountIf(sws.Rows(1), col3) > 0 Then
    col3 = Application.Match(col3, sws.Rows(1), 0)
    sws.Columns(col3).Copy dws.Range("C1")
    Application.CutCopyMode = 0
End If

If Application.CountIf(sws.Rows(1), col4) > 0 Then
    col4 = Application.Match(col4, sws.Rows(1), 0)
    sws.Columns(col4).Copy dws.Range("D1")
    Application.CutCopyMode = 0
End If

If Application.CountIf(sws.Rows(1), col5) > 0 Then
    col5 = Application.Match(col5, sws.Rows(1), 0)
    sws.Columns(col5).Copy dws.Range("E1")
    Application.CutCopyMode = 0
End If

If Application.CountIf(sws.Rows(1), col6) > 0 Then
    col6 = Application.Match(col6, sws.Rows(1), 0)
    sws.Columns(col6).Copy dws.Range("F1")
    Application.CutCopyMode = 0
End If

If Application.CountIf(sws.Rows(1), col7) > 0 Then
    col7 = Application.Match(col7, sws.Rows(1), 0)
    sws.Columns(col7).Copy dws.Range("G1")
    Application.CutCopyMode = 0
End If

If Application.CountIf(sws.Rows(1), col8) > 0 Then
    col8 = Application.Match(col8, sws.Rows(1), 0)
    sws.Columns(col8).Copy dws.Range("H1")
    Application.CutCopyMode = 0
End If

If Application.CountIf(sws.Rows(1), col9) > 0 Then
    col9 = Application.Match(col9, sws.Rows(1), 0)
    sws.Columns(col9).Copy dws.Range("I1")
    Application.CutCopyMode = 0
End If

If Application.CountIf(sws.Rows(1), col10) > 0 Then
    col10 = Application.Match(col10, sws.Rows(1), 0)
    sws.Columns(col10).Copy dws.Range("J1")
    Application.CutCopyMode = 0
End If

If Application.CountIf(sws.Rows(1), col11) > 0 Then
    col11 = Application.Match(col11, sws.Rows(1), 0)
    sws.Columns(col11).Copy dws.Range("K1")
    Application.CutCopyMode = 0
End If

If Application.CountIf(sws.Rows(1), col12) > 0 Then
    col12 = Application.Match(col12, sws.Rows(1), 0)
    sws.Columns(col12).Copy dws.Range("L1")
    Application.CutCopyMode = 0
End If

If Application.CountIf(sws.Rows(1), col13) > 0 Then
    col13 = Application.Match(col13, sws.Rows(1), 0)
    sws.Columns(col13).Copy dws.Range("M1")
    Application.CutCopyMode = 0
End If

If Application.CountIf(sws.Rows(1), col14) > 0 Then
    col14 = Application.Match(col14, sws.Rows(1), 0)
    sws.Columns(col14).Copy dws.Range("N1")
    Application.CutCopyMode = 0
End If

dws.Rows(1).Font.Bold = True
dws.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

Open in new window

Rerate-v5.4.sample.xlsm
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
If the desired columns may not be available on the Shipping Sheet and you want to know about those unavailable columns, you may replace the previous code with the following one.
After replacing the code, reassign the code to the button if you want to run the code by clicking the button.

Sub CopySpecificColumnsToReducedDataSheet()
Dim sws As Worksheet, dws As Worksheet
Dim col1, col2, col3, col4, col5, col6, col7, col8, col9, col10, col11, col12, col13, col14
Dim lc As Long
Dim msg As String
Application.ScreenUpdating = False
Set sws = Sheets("Shipping")
Set dws = Sheets("Reduced_data")

col1 = "Service Type"
col2 = "Package Type"
col3 = "Zone"
col4 = "Shipment Rated Weight"
col5 = "Original Weight"
col6 = "Pieces in Shipment"
col7 = "Index"
col8 = "Shipper State"
col9 = "Shipper Country"
col10 = "Recipient State"
col11 = "Recipient Country Code"
col12 = "Dimmed Height"
col13 = "Dimmed Width"
col14 = "Dimmed Length"
msg = "These columns are not present on " & sws.Name & " Sheet." & vbNewLine & vbNewLine
dws.Cells.Clear

If Application.CountIf(sws.Rows(1), col1) > 0 Then
    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col1 = Application.Match(col1, sws.Rows(1), 0)
    sws.Columns(col1).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0
Else
    msg = msg & col1 & vbNewLine
End If

If Application.CountIf(sws.Rows(1), col2) > 0 Then
    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col2 = Application.Match(col2, sws.Rows(1), 0)
    sws.Columns(col2).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0
Else
    msg = msg & col2 & vbNewLine
End If

If Application.CountIf(sws.Rows(1), col3) > 0 Then
    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col3 = Application.Match(col3, sws.Rows(1), 0)
    sws.Columns(col3).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0
Else
    msg = msg & col3 & vbNewLine
End If

If Application.CountIf(sws.Rows(1), col4) > 0 Then
    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col4 = Application.Match(col4, sws.Rows(1), 0)
    sws.Columns(col4).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0
Else
    msg = msg & col4 & vbNewLine
End If

If Application.CountIf(sws.Rows(1), col5) > 0 Then
    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col5 = Application.Match(col5, sws.Rows(1), 0)
    sws.Columns(col5).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0
Else
    msg = msg & col5 & vbNewLine
End If

If Application.CountIf(sws.Rows(1), col6) > 0 Then
    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col6 = Application.Match(col6, sws.Rows(1), 0)
    sws.Columns(col6).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0
Else
    msg = msg & col6 & vbNewLine
End If

If Application.CountIf(sws.Rows(1), col7) > 0 Then
    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col7 = Application.Match(col7, sws.Rows(1), 0)
    sws.Columns(col7).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0
Else
    msg = msg & col7 & vbNewLine
End If

If Application.CountIf(sws.Rows(1), col8) > 0 Then
    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col8 = Application.Match(col8, sws.Rows(1), 0)
    sws.Columns(col8).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0
Else
    msg = msg & col8 & vbNewLine
End If

If Application.CountIf(sws.Rows(1), col9) > 0 Then
    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col9 = Application.Match(col9, sws.Rows(1), 0)
    sws.Columns(col9).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0
Else
    msg = msg & col9 & vbNewLine
End If

If Application.CountIf(sws.Rows(1), col10) > 0 Then
    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col10 = Application.Match(col10, sws.Rows(1), 0)
    sws.Columns(col10).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0
Else
    msg = msg & col10 & vbNewLine
End If

If Application.CountIf(sws.Rows(1), col11) > 0 Then
    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col11 = Application.Match(col11, sws.Rows(1), 0)
    sws.Columns(col11).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0
Else
    msg = msg & col11 & vbNewLine
End If

If Application.CountIf(sws.Rows(1), col12) > 0 Then
    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col12 = Application.Match(col12, sws.Rows(1), 0)
    sws.Columns(col12).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0
Else
    msg = msg & col12 & vbNewLine
End If

If Application.CountIf(sws.Rows(1), col13) > 0 Then
    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col13 = Application.Match(col13, sws.Rows(1), 0)
    sws.Columns(col13).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0
Else
    msg = msg & col13 & vbNewLine
End If

If Application.CountIf(sws.Rows(1), col14) > 0 Then
    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col14 = Application.Match(col14, sws.Rows(1), 0)
    sws.Columns(col14).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0
Else
    msg = msg & col14 & vbNewLine
End If

lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
If lc <= 14 Then MsgBox msg
dws.Rows(1).Font.Bold = True
dws.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

Open in new window


Refer the attached workbook where I have changed the spelling of two columns Shipping State and Shipping Country, so these columns will not be copied to the Reduced_data sheet and you get a message with the columns names which are not present on the Shipping sheet in the end and the rest of the columns will be copied to the Reduced_data Sheet.
Rerate-v5.4.sample.xlsm
Euro5Author Commented:
Can we make it so that if the columns are not present, it just stops and does not paste anything?
Otherwise this is PERFECT!!!
C++ 11 Fundamentals

This course will introduce you to C++ 11 and teach you about syntax fundamentals.

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Okay try this.....

Sub CopySpecificColumnsToReducedDataSheet()
Dim sws As Worksheet, dws As Worksheet
Dim col1, col2, col3, col4, col5, col6, col7, col8, col9, col10, col11, col12, col13, col14
Dim lc As Long
Dim msg As String
Application.ScreenUpdating = False
Set sws = Sheets("Shipping")
Set dws = Sheets("Reduced_data")

col1 = "Service Type"
col2 = "Package Type"
col3 = "Zone"
col4 = "Shipment Rated Weight"
col5 = "Original Weight"
col6 = "Pieces in Shipment"
col7 = "Index"
col8 = "Shipper State"
col9 = "Shipper Country"
col10 = "Recipient State"
col11 = "Recipient Country Code"
col12 = "Dimmed Height"
col13 = "Dimmed Width"
col14 = "Dimmed Length"
msg = "These columns are not present on " & sws.Name & " Sheet." & vbNewLine & vbNewLine
dws.Cells.Clear

If Application.CountIf(sws.Rows(1), col1) = 0 Then
    MsgBox col1 & " is not present on " & sws.Name & "Sheet.", vbExclamation
    Exit Sub
End If

If Application.CountIf(sws.Rows(1), col2) = 0 Then
    MsgBox col2 & " is not present on " & sws.Name & "Sheet.", vbExclamation
    Exit Sub
End If

If Application.CountIf(sws.Rows(1), col3) = 0 Then
    MsgBox col3 & " is not present on " & sws.Name & "Sheet.", vbExclamation
    Exit Sub
End If

If Application.CountIf(sws.Rows(1), col4) = 0 Then
    MsgBox col4 & " is not present on " & sws.Name & "Sheet.", vbExclamation
    Exit Sub
End If

If Application.CountIf(sws.Rows(1), col5) = 0 Then
    MsgBox col5 & " is not present on " & sws.Name & "Sheet.", vbExclamation
    Exit Sub
End If

If Application.CountIf(sws.Rows(1), col6) = 0 Then
    MsgBox col6 & " is not present on " & sws.Name & "Sheet.", vbExclamation
    Exit Sub
End If

If Application.CountIf(sws.Rows(1), col7) = 0 Then
    MsgBox col7 & " is not present on " & sws.Name & "Sheet.", vbExclamation
    Exit Sub
End If

If Application.CountIf(sws.Rows(1), col8) = 0 Then
    MsgBox col8 & " is not present on " & sws.Name & "Sheet.", vbExclamation
    Exit Sub
End If

If Application.CountIf(sws.Rows(1), col9) = 0 Then
    MsgBox col9 & " is not present on " & sws.Name & "Sheet.", vbExclamation
    Exit Sub
End If

If Application.CountIf(sws.Rows(1), col10) = 0 Then
    MsgBox col10 & " is not present on " & sws.Name & "Sheet.", vbExclamation
    Exit Sub
End If

If Application.CountIf(sws.Rows(1), col11) = 0 Then
    MsgBox col11 & " is not present on " & sws.Name & "Sheet.", vbExclamation
    Exit Sub
End If

If Application.CountIf(sws.Rows(1), col12) = 0 Then
    MsgBox col12 & " is not present on " & sws.Name & "Sheet.", vbExclamation
    Exit Sub
End If

If Application.CountIf(sws.Rows(1), col13) = 0 Then
    MsgBox col13 & " is not present on " & sws.Name & "Sheet.", vbExclamation
    Exit Sub
End If

If Application.CountIf(sws.Rows(1), col14) = 0 Then
    MsgBox col14 & " is not present on " & sws.Name & "Sheet.", vbExclamation
    Exit Sub
End If

    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col1 = Application.Match(col1, sws.Rows(1), 0)
    sws.Columns(col1).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0

    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col2 = Application.Match(col2, sws.Rows(1), 0)
    sws.Columns(col2).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0

    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col3 = Application.Match(col3, sws.Rows(1), 0)
    sws.Columns(col3).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0

    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col4 = Application.Match(col4, sws.Rows(1), 0)
    sws.Columns(col4).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0

    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col5 = Application.Match(col5, sws.Rows(1), 0)
    sws.Columns(col5).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0

    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col6 = Application.Match(col6, sws.Rows(1), 0)
    sws.Columns(col6).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0

    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col7 = Application.Match(col7, sws.Rows(1), 0)
    sws.Columns(col7).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0

    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col8 = Application.Match(col8, sws.Rows(1), 0)
    sws.Columns(col8).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0

    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col9 = Application.Match(col9, sws.Rows(1), 0)
    sws.Columns(col9).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0

    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col10 = Application.Match(col10, sws.Rows(1), 0)
    sws.Columns(col10).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0

    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col11 = Application.Match(col11, sws.Rows(1), 0)
    sws.Columns(col11).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0

    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col12 = Application.Match(col12, sws.Rows(1), 0)
    sws.Columns(col12).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0

    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col13 = Application.Match(col13, sws.Rows(1), 0)
    sws.Columns(col13).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0

    lc = dws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    If dws.Cells(1, 1) = "" Then lc = 1
    col14 = Application.Match(col14, sws.Rows(1), 0)
    sws.Columns(col14).Copy dws.Cells(1, lc)
    Application.CutCopyMode = 0

dws.Rows(1).Font.Bold = True
dws.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

Open in new window

Euro5Author Commented:
@sktneer The code works perfectly for what I asked.
However, I didn't think it through....the macro stops running, but the rest of the macros run and lock up the computer because there is no data in there.

But I can't have it running without the necessary data, because that too results in an error.

Can we have an error handler END the whole vba run?
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
In all your IF Statements where you are checking whether a Columns exists on the Shipping Sheet, replace Exit Sub with End.

Make this change for all your IF blocks.

If Application.CountIf(sws.Rows(1), col1) = 0 Then
    MsgBox col1 & " is not present on " & sws.Name & "Sheet.", vbExclamation
    End
End If

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Euro5Author Commented:
That did it!!! Stopped running so they can fix and try again. Thank you SO MUCH.
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome.
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VB Script

From novice to tech pro — start learning today.