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]

You need to make the file accessible to anyone with the link - I was unable to open it...

 

[kevin9999]

Try the following on a copy of your workbook. Put the code in a standard module, and attach it to a button on your Summary sheet.

Option Explicit
Sub kofafa()
    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" 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")          '<~~ *** Change name if needed ***
                    .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

Here's the link to the mock workbook with all the above done: kofafa.xlsm

 

[kofafa]

You need to make the file accessible to anyone with the link - I was unable to open it...

oops. My bad. I changed it to anyone with the link. Thank you for everything. Much appreciated!!

 

[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!

 

[kofafa]

Hello,
Thank you very much for the code and also the tip!! You're amazing! Thank you! Below is the snip showing what I'm getting as an output from the code. it's outputting some cells that don't have a TAG in the C column. It's also giving me the error below. Sorry for the bother. Thanks for everything.

 

[kofafa]

Here is the link to my new workbook. Thanks!
PLUMBING FIXTURE & EQUIPMENT MATERIAL LIST UPDATED .xlsm

 

[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

 

[kofafa]

Kevin, You rock!! This is fantastic!!! Thank you for your help!!!

 

[kofafa]

Dear Kevin,

I apologize for bothering you again, but I require your assistance once more. I have been attempting to use the record macro feature to create a code for the same workbook, but unfortunately, I have been unsuccessful in my attempts. My goal is to create a code that performs the same task as the previous one, but with the added condition that if the tags in Column C of the summary sheet match the tag in Column M (within the M4 range) of the following sheets: LT-Lavatory Trim, MBT-Mop Basin Trim, SHV-Shower Valve, SKT-Sink Trim, URFV-Urinal Flush Valve, then the code should copy and paste the corresponding information into Columns I-L.

Thank you for your help.