Copy multiple rows from one book to another based on info in cell D

Hi all,

I am trying to do the following:

I have a workbook with a single worksheet that has about 2000 rows, columns A, B, C, D, E & F
Cells in colums A, B, C, E & F all have very different information in them, nothing is similar in any of those columns that I can base a criteria on.
Cells in column D however will have 1 of about 18 possibilities in them

What I want to do is have another workbook with 18 worksheets, each worksheet named 1 of the 18 possibilities, and somehow magically pull the data from the first workbook and insert it into the correct worksheet in the second workbook, leaving the data in the first workbook intact.

I update the first workbook several times a day, adding and deleting from it so would need to update as it goes, or be able to run the update as and when needed.

My skills are limited to simple formulas inserted into cells and dragging them down!

I'd really appreciate any help with this.
Thanks

Without seeing the two workbooks directly, not sure I could imagine a formula approach. But a macro could be run to do this pretty well.

If you provide the names of both workbooks (specify which is which), the full path to where you store these workbooks, I can help with that.

The macro would:
1) Open the "output" file if it isn't already open.
2) Go through all 18 sheets and "filter" the original workbook by the "name" of each worksheet in the second book, copying into the 2nd wb all the rows matching the sheetname.
3) Save the Output wb and/or close it again. (Your call there)

Let me know.

I have attached 2 example workbooks, turns out there are 35 possibilities that could be in cells in column D.

Extracting from Book1 to Book2, data remaining untouched in Book1

Thanks for your help.

Put this macro into Book2 and save it. Book1 and Book2 should reside in the same directory.

Option Explicit

Sub ImportData()
' JBeaucaire  8/19/2009
Dim ws As Worksheet, wsNw As Worksheet
Dim wb1 As Workbook, wb2 As Workbook
Dim LR As Long

Set wb2 = ThisWorkbook
Sheets.Add
Set wb1 = Workbooks.Open("Murphy-Book1.xls")
Cells.Copy
wb2.Activate
ActiveSheet.Paste
Rows("1:1").Insert Shift:=xlDown

wb1.Close False

Range("D1") = "Data"
Range("D1").AutoFilter
LR = Range("A" & Rows.Count).End(xlUp).Row
Set wsNw = ActiveSheet
    For Each ws In Worksheets
        If ws.Name <> wsNw.Name Then
            ws.UsedRange.Clear
            wsNw.Range("A1").AutoFilter field:=4, Criteria1:=ws.Name
            If Range("A" & Rows.Count).End(xlUp).Row > 1 Then _
                wsNw.Range("A2:H" & LR).Copy ws.Range("A1")
        End If
    Next ws
    
Application.DisplayAlerts = False
wsNw.Delete
Application.DisplayAlerts = True
End Sub

Which worksheet? You would add this line in red and edit it to your need:

...
...
Set wb2 = ThisWorkbook
Sheets.Add
Set wb1 = Workbooks.Open("Murphy-Book1.xls")
Sheets("Sheet3").Activate
Cells.Copy
wb2.Activate
ActiveSheet.Paste
...
...
...

It's designed that way. This code assumes it is was closed and we opened it and should now close it again.

wb1.Close False

We can check to see if it was open, and leave it open if it was:

Sub ImportData()
' JBeaucaire  8/20/2009
Dim ws As Worksheet, wsNw As Worksheet
Dim wb1 As Workbook, wb2 As Workbook
Dim LR As Long, chk As Boolean

chk = Evaluate("ISREF('[Murphy-Book1.xls]Sheet3'!A1)")

Set wb2 = ThisWorkbook
Sheets.Add

If Not chk Then
    Set wb1 = Workbooks.Open("Murphy-Book1.xls")
Else
    Set wb1 = Workbooks("Murphy-Book1.xls")
    wb1.Activate
End If

Sheets("Sheet3").Activate
Cells.Copy
wb2.Activate
ActiveSheet.Paste
Rows("1:1").Insert Shift:=xlDown

If Not chk Then wb1.Close False

Range("D1") = "Data"
Range("D1").AutoFilter
LR = Range("A" & Rows.Count).End(xlUp).Row
Set wsNw = ActiveSheet
    For Each ws In Worksheets
        If ws.Name <> wsNw.Name Then
            ws.UsedRange.Clear
            wsNw.Range("A1").AutoFilter field:=4, Criteria1:=ws.Name
            If Range("A" & Rows.Count).End(xlUp).Row > 1 Then _
                wsNw.Range("A2:H" & LR).Copy ws.Range("A1")
        End If
    Next ws
    
Application.DisplayAlerts = False
wsNw.Delete
Application.DisplayAlerts = True
End Sub

If that takes care of your need, be sure to EDIT your original post, click Go Advanced and mark the PREFIX box [SOLVED]. If the prefix box is no longer available, just add SOLVED to the start of the title.

(Also, use the blue "scales" icon in our posts to leave Reputation Feedback, it is appreciated)