Thread: Selecting certain rows across workbooks and compiling into one workbook

Sorry CapnSef, i didnt get a chance to look at your issue. Will do so right away.

I am attaching your workbook with a few revisions. The code is here as well as in the workbook. Some pointers so that the code works well -
1. Ensure that your header does not have any blank fields. Also, you have 2 rows of header, try and keep it in one row as i have done.
2. I have created a dropdown on the first tab called Main. I have kept the list of associates in column O of the Main page. You can store it anywhere and then hide the column. Just ensure that you update the formula in the data validation window to reflect the new column.
3. I found a hidden worksheet called "Mozart Reports" but couldnt unhide it, so i just specified that this sheet should not be included in the code. You can remove it from the code if this sheet should be included.
This is the code -

 
Option Explicit
Dim i As Long
Dim emplname As String

Sub copy_data()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Workbooks.Add
ActiveWorkbook.SaveAs "Employee Info"

ThisWorkbook.Worksheets("Sheet1").Rows("4:5").Copy Workbooks("Employee Info.xlsx").Worksheets(1).Range("A1")
emplname = ThisWorkbook.Worksheets("Main").Range("J10").Value
For i = 1 To ThisWorkbook.Worksheets.Count
    If ThisWorkbook.Worksheets(i).Name <> "Main" And ThisWorkbook.Worksheets(i).Name <> "Mozart Reports" Then
        ThisWorkbook.Worksheets(i).Rows(4).AutoFilter
        With ThisWorkbook.Worksheets(i).[a5].CurrentRegion
            .AutoFilter Field:=3, Criteria1:=emplname
            .Offset(1).SpecialCells(12).Copy Workbooks("Employee Info.xlsx").Worksheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1)
            .AutoFilter
        End With
    End If
Next i

Workbooks("Employee Info.xlsx").entirecolumn.autofit

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

I missed out on the date that you wanted against each entry. See revised code -

Option Explicit
Dim i As Long
Dim emplname As String
Dim frow As Long
Dim lrow As Long

Sub copy_data()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Workbooks.Add
ActiveWorkbook.SaveAs "Employee Info"
Workbooks("Employee Info.xlsx").Worksheets(1).Range("R1").Value = "Date"

ThisWorkbook.Worksheets("Sheet1").Rows("4:5").Copy Workbooks("Employee Info.xlsx").Worksheets(1).Range("A1")
emplname = ThisWorkbook.Worksheets("Main").Range("J10").Value
For i = 1 To ThisWorkbook.Worksheets.Count
    If ThisWorkbook.Worksheets(i).Name <> "Main" And ThisWorkbook.Worksheets(i).Name <> "Mozart Reports" Then
        ThisWorkbook.Worksheets(i).Rows(4).AutoFilter
        With ThisWorkbook.Worksheets(i).[a5].CurrentRegion
            .AutoFilter Field:=3, Criteria1:=emplname
            .Offset(1).SpecialCells(12).Copy Workbooks("Employee Info.xlsx").Worksheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1)
            .AutoFilter
        End With
        frow = Workbooks("Employee Info.xlsx").Worksheets(1).Range("R" & Rows.Count).End(xlUp).Row
        lrow = Workbooks("Employee Info.xlsx").Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
        Workbooks("Employee Info.xlsx").Worksheets(1).Range("R" & frow + 1 & ":R" & lrow).Value = ThisWorkbook.Worksheets(i).Range("C2").Value
    End If
Next i

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Arlette

Thank you so much for taking the time to stay with me on this issue. Your solution looks promising and is nearly perfect, however I think you have outdone yourself.

I do not need your script to worry about the header - the generation of the reports is not my field, so I cannot consolidate the header on future reports. I plan to manually recreate the header myself when I run the script.

The workbooks I plan on using it on will look like the file I've attached. Ignoring the header (two lines is unfortunately a byproduct of our report generation software), it should pull the full line that matches the associate and drop the raw (unedited) row into a new sheet/workbook. Currently, your script creates a header in the new workbook for me - fortunately, this isn't necessary. I get a "Subscript out of range" error running your current revision of code on the attached excel document. I'm unsure if that is due to the nature of my reports (two lined headers) or what, but if you disregard that header and simply search the columns for matching associates I feel as if we can avoid the inconsistent nature of the reports.

In simplest terms, I just need to "cherry-pick" rows out of each sheet and plop them into a new one alongside the date of their original sheet.

The current script gives me "Runtime error 9, subscript out of range" on line:

Workbooks("Employee Info.xlsx").Worksheets(1).Range("R1").Value = "Date"

After it opens the header in a new document. If we stop trying to recreate the header, I think this will go away. It simply needs to copy the specified associate line, drop it in a new sheet, and check the next sheet in the workbook.

EDIT: Also, I noticed your code takes the name of the associate, however it does not account for the fact names are stored as 2 fields - first as well as last. Could you set it to enable me to give a first and last name, and only copy associates matching both criteria?

Thank you again so much Arlette!

The reason you are getting the error is because i believe the macro is creating a .xls file (excel 2003). Are you using excel 2003 or 2007 for your report? You can change the line which gives you the error to

Workbooks("Employee Info.xls").Worksheets(1).Range("R1").Value = "Date"

if you are using 2003.

Regarding your last point, i missed out on adding that point to previous post. I was going to ask if you if it was possible to merge both the fields into one field? I am asking you this to avoid further complications with regard to the dropdown in the "Main" page that i have attached in post 17. The code uses autofilter to get the records for the associate. It will be complicated n messy if we try to filter on 2 fields.

I am using Excel 2010 to run these macros. I don't have the ability to merge the fields into one in any effecient manner, as the form in which I receive the reports is relatively "set in stone." (The guy generating the reports is kind of... ignorant :P)

It shouldn't be an issue, my workers are unique by last name (for the most part.) If we could simply autofilter by the contents of the column carrying last name, that would be sufficient. We can, however, not build the header into the output file (since the header is ugly anyway :P).

As I'm messing with the macro we currently have going, I can't help but feel the Main page is a bit cumbersome - for my purposes, would it at all be possible to just set a variable within the macro itself that I could edit to do the autofilter? For instance, if I want "Hunt" for the last name (stored in column C) I would change the variable 'emplname' within the macro manually "Hunt" and run it on any of the pages within the workbook?

Ok, in that case the code will still work. Just ensure that you have the dropdown (in the Main tab of the file that i had attached) consists of the last names.

Regarding the header, if the ugly format is always constant in its ugliness then we can code it to re-format it.

I'll be manually recreating the header in the output file, so that isn't really a worry. Reformatting the header would mean running another macro on the workbook just to clean the formatting of the source files up, which is all around unnecessary since the output is more important than the input as far as I'm concerned. The primary goal of this macro is solely to trawl what could be hundreds of reports for certain associates and compiling them. Anything beyond that we can safely ignore, so so long as the macro can copy the associate's row and date per sheet it has done its job.

Edit:

Everything appears to be working GREAT now!

I made only this single modification to your code:

Option Explicit
Dim i As Long
Dim emplname As String
Dim frow As Long
Dim lrow As Long

Sub copy_data()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Workbooks.Add
ActiveWorkbook.SaveAs "Employee Info"
Workbooks("Employee Info.xlsx").Worksheets(1).Range("R1").Value = "Date"

ThisWorkbook.Worksheets("Sheet1").Rows("4:5").Copy Workbooks("Employee Info.xlsx").Worksheets(1).Range("A1")
emplname = "stringgoeshere"
For i = 1 To ThisWorkbook.Worksheets.Count
    If ThisWorkbook.Worksheets(i).Name <> "Main" And ThisWorkbook.Worksheets(i).Name <> "Mozart Reports" Then
        ThisWorkbook.Worksheets(i).Rows(4).AutoFilter
        With ThisWorkbook.Worksheets(i).[a5].CurrentRegion
            .AutoFilter Field:=3, Criteria1:=emplname
            .Offset(1).SpecialCells(12).Copy Workbooks("Employee Info.xlsx").Worksheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1)
            .AutoFilter
        End With
        frow = Workbooks("Employee Info.xlsx").Worksheets(1).Range("R" & Rows.Count).End(xlUp).Row
        lrow = Workbooks("Employee Info.xlsx").Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
        Workbooks("Employee Info.xlsx").Worksheets(1).Range("R" & frow + 1 & ":R" & lrow).Value = ThisWorkbook.Worksheets(i).Range("C2").Value
    End If
Next i

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Now I can specify an associate and receive pretty much all their transaction dates!
I'll be marking this as solved shortly assuming I don't generate any glaring bugs, and adding plenty of reputation! Thank you SO MUCH!

Edit: If I could make one request, could this code be modified to not copy the headers at all? The way I modify the output data it would flow better if the headers aren't copied over into the output file, if it isn't simple however it isn't a problem for me to modify it manually.

Np at all. Just remove this line from the code -

 ThisWorkbook.Worksheets("Sheet1").Rows("4:5").Copy Workbooks("Employee Info.xlsx").Worksheets(1).Range("A1")

You could alternatively put an "'" (single quote) before the line which will prevent it from running.

I am glad it worked. Thanks for the rep.