Need VBA that scours multiple sheets, reviews all columns (after column A and the header row) and if all cells in a row are empty, return the value in

[TaylorEX]

Ok, so I have a blank sheet 1. Then several additional sheets (5-10) with data loaded to them. Every time the VBA is run it should move to sheet 2 and search through every single row with a value in column A (excluding the header row). Any row that doesn't have a value in any of the columns (excluding column a) copy the value of column A in that row to sheet 1, then go back to that sheet and continue looking at all the rows, when the next criteria is met it should go back to sheet 1 and paste to the next row. Once this is complete it needs to go the next sheet and repeat the process. Then on to the next sheet, etc until all sheets have been reviewed.

The other catch is for each new sheet it reviews it needs to skip a line and then put the sheet name as the next value so I can determine which values come from what sheet (if these can be bolded and highlighted as in the example that would be even better). I've made a very simplified version of what I'm looking for. The actual version has 100s of additional rows and several more columns. Please see the images below. Thanks to anybody who can help.

After the vba runs the Results sheet would look like this based on the Group 1 and Group 2 example sheets

 

[Trebor76]

Hi TaylorEX,

Try this:

Option Explicit
Sub Macro1()

    Dim wsMySheet As Worksheet
    Dim lngMyRow As Long
    Dim lngLastRow As Long
    Dim lngLastCol As Long
    Dim blnUsedSheetName As Boolean
    
    Application.ScreenUpdating = False
    
    For Each wsMySheet In ThisWorkbook.Sheets
        If wsMySheet.Name <> "Results" Then
            lngLastRow = wsMySheet.Cells(Rows.Count, "A").End(xlUp).Row
            If lngLastRow > 4 Then 'Check if there's more data than the header row
                For lngMyRow = 5 To lngLastRow
                    lngLastCol = wsMySheet.Cells(lngMyRow, Columns.Count).End(xlToLeft).Column
                    If lngLastCol = 1 Then
                        If blnUsedSheetName = False Then
                            With Sheets("Results").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                                .Value = wsMySheet.Name
                                .Font.Bold = True
                                blnUsedSheetName = True
                            End With
                        End If
                        Sheets("Results").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = wsMySheet.Range("A" & lngMyRow)
                    End If
                Next lngMyRow
            End If
        End If
        blnUsedSheetName = False
    Next wsMySheet
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[Peter_SSs]

You could also try this in a copy of your workbook.
This assumes that
- the sheet collecting the results is the first sheet in the workbook (I think that was what you described).
- column J on that first sheet is available to use as a helper column. Edit code to another column if that is not so.

Sub CollectInfo()
  Dim i As Long
  Dim rCrit As Range
  Dim ws As Worksheet
  
  With Sheets(1)
    Set rCrit = .Range("J1:J2") '<- Edit if required
    For i = 2 To Sheets.Count
      Set ws = Sheets(i)
      If ws.UsedRange.Rows.Count > 1 Then
        rCrit(2).Formula = Replace("=AND('#'!A2<>"""",COUNTA('#'!2:2)=1)", "#", ws.Name)
        ws.UsedRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rCrit, Unique:=False
        ws.UsedRange.Columns("A").SpecialCells(xlVisible).Copy Destination:=.Range("A" & Rows.Count).End(xlUp).Offset(2)
        If ws.FilterMode Then ws.ShowAllData
        With .Range("A" & .Rows.Count).End(xlUp).CurrentRegion.Cells(1)
          .Value = ws.Name
          .Font.Bold = True
          .Interior.Color = 14994616
        End With
      End If
    Next i
    rCrit.ClearContents
  End With
End Sub

 

[TaylorEX]

First and foremost I know everybody doing this is doing this voluntarily so I just want to say how much I really appreciate your help...thank you both so much.

So I tested this on a new demo workbook I created today (based on the same criteria/layout as the screenshot...the actual document I need this for isn't available on this pc).

Trebor's code worked perfectly in terms of the returned results, they were accurate. Worst case scenario this would work just fine and I can handle the spacing/highlighting manually for all the sheets/entries. Basically it returned the sheet name bolded at the top and then the results with no spacing before the next sheet and no highlighting (as I said, this isn't the end of the world).

Peter's code returned results which visually looked exactly how I was hoping. Bold sheet names, Highlighted, with a space before the next sheets results are displayed...however when I looked at the results themselves they weren't pulling based on blank rows (after column A). I can't really determine what the criteria is that it's pulling. Really what I'm hoping for (and again, I can make due with Trebor's original code if you guys are busy and aren't able to follow-up) is a combination of these two. The visual output of Peters code with the accuracy of Trebors VBA. Either way I just want to thank you both again for your help.

I figure it probably helps more to see the results and the new sheets vs me explaining it. So keep in mind this is a new test workbook I tried it on. Here are the sheets that are being reviewed to have the results pulled (after the test 2 sheet I just duplicated the same sheet over and over again to make sure it would look at more than a few sheets):

Here are the results of Trebors code:

And Peters:

 

[Trebor76]

Here's my macro tweaked:

Option Explicit
Sub Macro2()

    Dim wsMySheet As Worksheet
    Dim lngMyRow As Long
    Dim lngLastRow As Long
    Dim lngLastCol As Long
    Dim blnUsedSheetName As Boolean
    
    Application.ScreenUpdating = False
    
    For Each wsMySheet In ThisWorkbook.Sheets
        If wsMySheet.Name <> "Results" Then
            lngLastRow = wsMySheet.Cells(Rows.Count, "A").End(xlUp).Row
            If lngLastRow > 4 Then 'Check if there's more data than the header row
                For lngMyRow = 5 To lngLastRow
                    lngLastCol = wsMySheet.Cells(lngMyRow, Columns.Count).End(xlToLeft).Column
                    If lngLastCol = 1 Then
                        If blnUsedSheetName = False Then
                            With Sheets("Results").Range("A" & Rows.Count).End(xlUp).Offset(2, 0)
                                .Value = wsMySheet.Name
                                .Font.Bold = True
                                .Interior.Color = RGB(184, 204, 228)
                                blnUsedSheetName = True
                            End With
                        End If
                        Sheets("Results").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = wsMySheet.Range("A" & lngMyRow)
                    End If
                Next lngMyRow
            End If
        End If
        blnUsedSheetName = False
    Next wsMySheet
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[Peter_SSs]

For mine, I hadn't picked up on the headings being in row 4 of the other sheets. I've made an adjustment below, but without knowing all about those 'other' sheets, my code may need a little more tweaking yet.

For a start, try making these two substitutions in the code.

<del>ws.UsedRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rCrit, Unique:=False</del>
ws.Range("A4").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rCrit, Unique:=False
<del>ws.UsedRange.Columns("A").SpecialCells(xlVisible).Copy Destination:=.Range("A" & Rows.Count).End(xlUp).Offset(2)</del>
ws.Range("A4", ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1)).SpecialCells(xlVisible).Copy Destination:=.Range("A" & Rows.Count).End(xlUp).Offset(2)

If there are still incorrect results returned..

1. Do all the 'other' sheets have something in row 1 somewhere?

2. Do all the 'other' sheets have the same fixed number of columns of data from row 4 down? If so, what columns?

 

[TaylorEX]

Robert - The code you provided works perfectly on the test sheet. I'll have a chance to test it tomorrow but my guess is it will be fine.

Peter - I tested your code as well just to see if the alterations would fix it. It looks like it's still returning incorrect results. Robert's code looks to work, but in the event you still wanted the information requested to spot check, none of the other sheets have anything in row 1 and on the actual document there won't be a fixed number of columns (each sheet my have a different number of columns) however on the test sheet I've been working off of they all have the same number of columns (A-E).

I just wanted to thank you both again for contributing and helping me find a solution to this. I really really really appreciate. Thank you both so much.

 

[Trebor76]

Thanks for the feedback and I'm glad we were able to get it sorted

 

[TaylorEX]

Thanks Robert, just to follow up, tested today within the actual document. Worked out great. You guys are great.

 

[Trebor76]

That's great. Thanks again