Sorry my title is so long, I wasn't sure how to shorten it without giving a good description of my problem.

I have a spreadsheet with about 12 columns of data and 600 rows. I need to copy these columns from one sheet to another but they must be in a specific order. The header row cell values are the same in both sheets, so that's what I'm using to search by. Is there a way I can do a loop to run through my header values find which ones I need to copy and then copy to the last row of data for each column?

I've got the code to paste it in the next workbook, but I just don't know how to get it there in the proper order.

My code is at work, but if someone can point me in the right direction, I'd appreciate it! Thanks!

Hi Keri,

I couldn't tell whether you were wanting to copy just the last row of data from the copy range to the paste range, or whether you wanted to copy all data from the copy range to the next available row in the paste range. The subroutine I wrote below works on the assumption that you wish to copy all of the data from the copy range to the next available row on the paste range.

The first thing you'll need to do is to update the copy and paste worksheets and column header ranges. Once those are correct, the subroutine will first check each column header in the copy range against the column headings in the paste range. If all are found to have matches, then the columns are copied to the appropriate places. If any columns do NOT match, a message will appear that lists the columns not found and prompts the user to continue or cancel.

If the user cancels, the sub ends with no changes to the data. If the user continues, only the columns with matching headers will be copied over and a message indicating which columns were NOT copied will appear.

I hope this is what you were looking for.

Ben


Sub CopyColumns()
Dim wsCopy As Worksheet 'Source worksheet
Dim wsDest As Worksheet 'Destination worksheet
Dim rCopy As Range 'Source header range
Dim rPaste As Range 'Destination header range
Dim rHeader As Range
Dim lCRow As Long 'Last row of data to copy
Dim lPRow As Long 'Last row of existing data
Dim sError As String 'Error message text

'First, assign worksheets
Set wsCopy = ThisWorkbook.Sheets(Sheet1.Name)
Set wsDest = Workbooks("Book1").Sheets(Sheet3.Name)

'Next, find last rows and header ranges
lCRow = wsCopy.Range("64000:64000").End(xlUp).Row
lPRow = wsDest.Range("64000:64000").End(xlUp).Row
Set rCopy = wsCopy.Range("A1:L1")
Set rPaste = wsDest.Range("A1:L1")

'Check that all columns match
On Error Resume Next
Application.ScreenUpdating = False
For Each rHeader In rCopy 'Find "copy" header in the "paste" header range
rPaste.Find(rHeader.Value, rPaste.Range("A1"), , xlWhole).Activate
If Err.Number < 0 Then 'Header name not found, build an error message
sError = sError & vbCr & rHeader.Value
Err.Clear
End If
Next rHeader
If Len(sError) 0 Then 'Not all match, so offer a chance to exit
If MsgBox("Could not paste the following columns: " & vbCr & sError & vbCr & vbCr & _
"Would you like to paste the remaining columns?" & vbCr & vbCr & _
"Click 'OK' to continue or 'Cancel' to end.", vbOKCancel + vbExclamation, _
"Columns not found") = vbOK Then 'User elected to continue
sError = vbNullString
Else 'User elected to cancel
Application.ScreenUpdating = True
MsgBox "Action cancelled"
Exit Sub
End If
End If

'Then loop through copy headers and paste
For Each rHeader In rCopy 'copy and paste to the correct column
wsCopy.Range(Cells(2, rHeader.Column).Address & ":" & Cells(lCRow, rHeader.Column).Address).Copy _
rPaste.Find(rHeader.Value, rPaste.Range("A1"), , xlWhole).Offset(lPRow, 0)
If Err.Number < 0 Then '"copy" header not found in "paste" header range, build error message
sError = sError & vbCr & rHeader.Value
Err.Clear
End If
Next rHeader
If Len(sError) 0 Then 'Some columns not pasted, let user know which ones.
MsgBox "Could not paste the following columns: " & vbCr & sError & vbCr & vbCr & _
"All others copied over.", vbInformation, "Not all columns copied"
Else 'All went according to plan.
MsgBox "All columns copied successfully", , "Success!"
End If

'Clear objects
Application.ScreenUpdating = True
Set rCopy = Nothing
Set rPaste = Nothing
Set rHeader = Nothing

End Sub

Hi Ben,

Thanks for the code. That's what I was looking for. I actually ended up just doing this because I didn't get your message in time:

I had to make a separate sub procedure for each term I was looking for (I put them all in a run all procedure) and increase the destination column references each time, but it worked. If I ever have to do this again, I'll give your code a try, it is probably much more efficient and less time consuming to set up. Thanks for the response!

Keri,

Thanks for the feedback, I'm happy to help. Glad to hear that you worked out a solution.

Ben