Home |
Search |
Today's Posts |
#1
|
|||
|
|||
Loop through cells to find a string and copy/paste the matching column to a new wkbk
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! |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Loop through cells to find a string and copy/paste the matchingcolumn to a new wkbk
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 |
#3
|
|||
|
|||
Quote:
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: 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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Loop through cells to find a string and copy/paste the matchingcolumn to a new wkbk
Keri,
Thanks for the feedback, I'm happy to help. Glad to hear that you worked out a solution. Ben |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
loop thru cells to find matching record | Excel Programming | |||
VBA Loop to Find then Copy & Paste | Excel Discussion (Misc queries) | |||
Copy & paste ranges from 1 wkbk to another | Excel Programming | |||
Find matching date in another worksheet, copy and paste data | Excel Discussion (Misc queries) | |||
Loop cells - get all rows with matching data - paste into different wb | Excel Programming |