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