Loop through cells to find a string and copy/paste the matching column to a new wkbk

[KeriM]

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

I have a spreadsheet with about 12 columns of data and 600 rows. I nee
to copy these columns from one sheet to another but they must be in
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 t
run through my header values find which ones I need to copy and the
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'
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

 

[Ben McClave]

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 arecopied 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 usercontinues, 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

 

[KeriM]

Hi Keri,

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

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

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

I hope this is what you were looking for.

Ben

Hi Ben,

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


Code
-------------------


Sub Copy()

Dim cell As Range
Dim targetCell As Range, targetSheet As Worksheet, ws As Workbook
Dim lastcell As Integer
Fname = "dest file name"
Set rName = Workbooks(Fname)

Set targetSheet = rName.Sheets(1)
rName.Activate
targetSheet.Select
targetSheet.Cells(1, 1).Select
lastcell = targetSheet.Range("M1").End(xlDown).Row
Set targetCell = targetSheet.Cells(lastcell + 1, 1)

For Each ws In Workbooks
If ws.Name Like "*July*" Then Windows(ws.Name).Activate
Next

Cells.Find(What:="Find Term", LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate

ncol = ActiveCell.Column

LRow = Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(2, ncol), Cells(LRow, ncol)).Copy

targetSheet.Paste Destination:=targetCell
Set targetCell = targetCell.Offset(0, 1)

Application.CutCopyMode = False

End Sub


-------------------


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

 

[Ben McClave]

Keri,

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

Ben