Pulling rows from multiple sheets and pasting values in appropriate matching headers in a summary sheet.

[kofafa]

Hi there,

I am new to VBA and I need help finding a code to extract data from rows in various worksheets with different names, except for the data sheet. The extracted data needs to be pasted and sorted on a summary sheet located at the beginning of the workbook. To give you an idea, I want the code to automatically extract the corresponding row when any value is added to Column B from any worksheet. It should only extract cells under headers with green color and paste them under matching headers colored green in the summary sheet. Can you please assist me with this? Thank you.

 

[kevin9999]

OK, couple of things. Firstly, I wasn't aware that there was another sheet other than "Summary" that wasn't meant to be included in the copy - I'm talking about the sheet you called "DATA". Secondly, I was under the impression that all sheets were structured/formatted the same - the sheet called "WC - WATER CLOSET" starts in column B, not in column C like all other sheets?!
When I made that sheet the same as all the others, and added code to ignore the DATA sheet as well, the code ran exactly as expected. Code below, link to the amended file here:
PLUMBING FIXTURE & EQUIPMENT MATERIAL_LIST3.xlsm

Option Explicit
Sub Run()
    Dim ws As Worksheet, a, InArr, OutArr, i As Long, j As Long, LRow As Long, rng As Range
    Application.EnableEvents = False
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Summary" And ws.Name <> "DATA" Then
            With ws
                LRow = .Cells(Rows.Count, "C").End(xlUp).Row
                Set rng = .Range(.Cells(4, 3), .Cells(LRow, 11))
                ReDim a(1 To LRow - 3, 1 To 15)
                InArr = Array(1, 2, 3, 6, 7, 8, 9)
                OutArr = Array(1, 2, 6, 3, 4, 5, 15)
                For i = LBound(a, 1) To UBound(a, 1)
                    For j = 0 To 6
                        a(i, OutArr(j)) = rng.Cells(i, InArr(j))
                    Next j
                Next i
                With Worksheets("Summary")
                    .Range("C" & .Cells(Rows.Count, "C").End(xlUp).Row + 1).Resize(LRow - 3, 15).Value = a
                End With
            End With
        End If
    Next ws
    Application.EnableEvents = True
End Sub

 

[kevin9999]

Just another tip - avoid merged cells like the plague!

 

[kevin9999]

Try the following amended code. Link to the file below:
PLUMBING FIXTURE & EQUIPMENT MATERIAL LIST UPDATED .xlsm

Option Explicit
Sub Run()
    Dim ws As Worksheet, a, InArr, OutArr, i As Long, j As Long, LRow As Long, rng As Range
    Application.EnableEvents = False
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Summary" And ws.Name <> "DATA" Then
            With ws
                LRow = .Cells(Rows.Count, "C").End(xlUp).Row
                If LRow > 3 Then
                    Set rng = .Range(.Cells(4, 3), .Cells(LRow, 11))
                    ReDim a(1 To LRow - 3, 1 To 15)
                    InArr = Array(1, 2, 3, 6, 7, 8, 9)
                    OutArr = Array(1, 2, 6, 3, 4, 5, 15)
                    For i = LBound(a, 1) To UBound(a, 1)
                        For j = 0 To 6
                            a(i, OutArr(j)) = rng.Cells(i, InArr(j))
                        Next j
                    Next i
                    With Worksheets("Summary")
                        .Range("C" & .Cells(Rows.Count, "C").End(xlUp).Row + 1).Resize(LRow - 3, 15).Value = a
                    End With
                End If
            End With
        End If
    Next ws
    LRow = Worksheets("Summary").Cells.Find("*", , xlFormulas, , 1, 2).Row
    With Worksheets("Summary").Range("C8:Q" & LRow)
        .AutoFilter 1, "="
        .Offset(1).EntireRow.Delete
        .AutoFilter
    End With
    Application.EnableEvents = True
End Sub

 

[kevin9999]

It's always better if you provide a copy of your sheets using the XL2BB add in so helpers don't have to type out your data layout to test their code. Alternatively, you can share your workbook via Dropbox, Google Drive or similar file sharing platform.
You haven't said what your summary sheet is called, so the code below assumes it's called "Summary" - change this in two places if it's called something else. The code needs to go in the Workbook module, and I assume you know how to do this. If you don't, see this: How to Add Macro Code to Excel Workbook. The code also assumes that you don't have any other worksheets other than the summary sheet, and all the other sheets have the exact same structure as your top image.

Private Sub Workbook_SheetChange(ByVal ws As Object, ByVal Target As Range)
    If ws.Name = "Summary" Then Exit Sub    '<~~ *** Change name if needed ***
    If Target.Cells.CountLarge = 1 And Not Intersect(Target, Columns(2)) Is Nothing Then
        On Error GoTo Escape
        Application.EnableEvents = False
        Dim a, b, InArr, OutArr, i As Long, rng As Range
        With ws
            Set rng = Target.Offset(0, 1).Resize(1, 9)
            ReDim b(1 To 1, 1 To 15)
            InArr = Array(1, 2, 3, 6, 7, 8, 9)
            OutArr = Array(1, 2, 6, 3, 4, 5, 15)
            For i = 0 To 6
                b(1, OutArr(i)) = rng.Cells(1, InArr(i))
            Next i
        End With
        With Worksheets("Summary")          '<~~ *** Change name if needed ***
            .Range("C" & .Cells(Rows.Count, "C").End(xlUp).Row + 1).Resize(1, 15).Value = b
        End With
    End If
Continue:
    Application.EnableEvents = True
    Exit Sub
Escape:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Continue
End Sub

 

[kofafa]

Hello Kevin999,
Thank you so much for your help!! Much appreciated! I copied and pasted the code in the workbook module. unfortunately, I'm unable to run it. Please help.

 

[kevin9999]

It's probably easier if I show you. This is a link to the file with the workbook code in the correct place: kofafa.xlsm

 

[kofafa]

Hi Kevin,

I am grateful for your assistance! May I request further help from you? I would like to incorporate a button on the summary page which, when clicked, will populate the summary page instead of auto-populating it.

Thank you!

 

[kevin9999]

Do you mean populate the summary sheet with all available data from all the worksheets in one go?

 

[kofafa]

Yes, that's correct. I'm attempting to send my workbook, but my Excel program keeps disabling the XL2bb.