VBA - Pulling a row from each sheet based on column B value, pasting in new sheet

[Greshapa]

Hello,

Its my first time posting here, thanks in advance for any assistance

I have a workbook with about 50 sheets, each sheet is a monthly report (seen blow) with production and sales data for various products. What I would like to do, is extract one products data from each sheet (Lets say, the "2A" products row that i circled in red) and bring it into its own new sheet. In this new 2A sheet, there will be a table just like in my screenshot, except the only product will be 2A, and each row will be one month of 2A data

I'm new to using VBA so my issues are that 1.) the products data is not always in the same row (But it is always in column B) and 2.) I'm not sure how to make a macro that would switch back and forth between various sheets and copy data to a new sheet. All of my previous VBA macro experience has been taking data from one sheet, copying it to a new sheet, and formatting it to look nice.

 

[Max1616]

Hello, give this a try:

Sub Product_Consolidate()
Dim NewWs As Worksheet
Dim i As Long
Dim ws As Worksheet
Dim lrow As Long
Dim NewWsLrow
Dim Product As String

Product = "2B" '***Specify product name here

Set NewWs = Sheets.Add(After:=Sheets(Sheets.Count))  'Create new sheet and name it the product name
NewWs.Name = Product

Sheets(1).Range("B3:H3").Copy NewWs.Range("B3:H3") 'Paste headers to new sheet
NewWs.Range("I3") = "SheetName"

For Each ws In ActiveWorkbook.Worksheets 'This line starts the loop through each sheet
    If ws.Name <> NewWs.Name Then 'May need to add criteria to only run this on sheets that are a month name (I'm unsure what your workbook sheets look like)
        lrow = ws.Cells(Rows.Count, 2).End(xlUp).Row
        For i = 4 To lrow '4 represents the row the data starts in. This line starts the loop to look through the product in each sheet
            If ws.Cells(i, 2) = Product Then
                NewWsLrow = NewWs.Cells(Rows.Count, 2).End(xlUp).Row
                ws.Cells(i, 2).EntireRow.Copy NewWs.Cells(NewWsLrow + 1, 2).EntireRow 'If the loop finds the product name, then paste it to the new sheet
                NewWs.Cells(NewWsLrow + 1, 9) = ws.Name 'Add in the name of the sheet the data is coming from
            End If
        Next i
    End If
Next ws

End Sub

It will loop through all sheets, and then loop through all rows on the sheet to look for the product "2A" (2A can be edited in the code where I commented at the top). Once it finds the product it will paste the entire row to a new sheet with titled the name of the product. I also added a column in the new sheet that has the name of the original sheet the data came from.

The call-outs to this code is that :
1. You have to hard-code the sheet into the code (there's ways around this with input boxes that I can add for you if you'd like)
2. That you can only run it once per product, as running it a second time will error because a sheet with the product name already exists.

 

[akaseto]

lets says u extraced all to Data sheets

Sub test()
Dim i, x, ws As Worksheet
Dim lastrow As Long, destrow As Long
Dim product

product = Application.InputBox("Enter Product")
destrow = Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
For Each ws In Worksheets
If ws.Name <> "Data" Then
With ws
lastrow = .Cells(Rows.Count, "B").End(xlUp).Row

For x = 1 To lastrow
If .Cells(x, "B").Value = product Then
.Rows(x).Copy Destination:=Sheets("Data").Rows(destrow)
destrow = destrow + 1
End If
Next x
End With
End If
Next ws
End Sub

please consider
this will copy all rows that contain entered product name (column B) in input box to last row column A in Sheets Data

 

[Greshapa]

Thanks so much, both of you!!! Max, that worked perfectly with a few small tweaks. The main thing i had to change was `For i = 4 To lrow` to `For i = 4 To 25` so that I didnt pick up un needed rows that weren't visible in my screenshot


I really appreciate it!