VBA - Return all rows based on two criteria

[nellyc]

Hi

I have been looking through the forum for a code to return all rows from every sheet in a workbook based on a two criteria match but without success.

I would like a code that will return all rows, in all sheets, to a new sheet at the start of the workbook.
Based on the criteria in two drop downs in a sheet called "Summary One"
The first criteria is in "A2" and the matching data is in Column "H" in every sheet in the workbook
The second Criteria is in "A4" and the matching data is in Column "K" in every sheet in the workbook

I will link the code to a button in the "Summary One" sheet to run the report (new sheet).
The report will need the headings, A1 to K1 (the same headings are in all sheets)
Then the data from "A" to "K" starting at row 2 but from all the sheets in the workbook under the heading
Data Format - Arial 11, Black font, Headers (Row 1) in bold, no boarders.

Is this possible to do this?

 

[DanteAmor]

Hi @nellyc . Thanks for posting on the forum

Please try the following macro.
Just set the name you'd like for the new sheet on this line of the macro:

sName = "Report"

Full macro:

Sub ReturnRows()
  Dim shS As Worksheet, shA As Worksheet, shN As Worksheet
  Dim sName As String
  Dim copyhead As Boolean
  Dim lra As Long, lrn As Long
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  sName = "Report"
  On Error Resume Next: Sheets(sName).Delete: On Error GoTo 0
  Sheets.Add(Sheets(1)).Name = sName
  Set shN = Sheets(sName)
  
  Set shS = Sheets("Summary One")
  
  For Each shA In Sheets
    Select Case shA.Name
      Case shS.Name, shN.Name
      
      Case Else
        If copyhead = False Then
          copyhead = True
          shA.Range("A1:K1").Copy shN.Range("A1")
          With shN.Range("A1:K1")
            .Font.Bold = True
            .Font.Name = "Arial"
            .Font.Size = 11
          End With
        End If
        
        lra = shA.Range("H" & Rows.Count).End(3).Row
        lrn = shN.Range("H" & Rows.Count).End(3).Row + 1
        shA.Range("A1:K" & lra).AutoFilter 8, shS.Range("A2").Value
        shA.Range("A1:K" & lra).AutoFilter 11, shS.Range("A4").Value
        shA.AutoFilter.Range.Range("A2:K" & lra).Copy shN.Range("A" & lrn)
        shA.ShowAllData
    End Select
  Next
  
  shN.Select
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  MsgBox "Fin"
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
--------------

 

[nellyc]

Thank you Dante

The code is working great, however can you modify the code to clear any filters first as the first times i ran it it returned nothing as there was filters applied.

Also Columns A&B are white font in the data can they be Black in the report ?

And lastly once the code has finished a pop up is left on the screen, red cross and "400" clicking "OK" seems to end the code.

Great work

 

[DanteAmor]

- clear any filters first ...
- Also Columns A&B are white font in the data can they be Black ...
- And lastly once the code has finished a pop up...

Try this:

Sub ReturnRows()
  Dim shS As Worksheet, shA As Worksheet, shN As Worksheet
  Dim sName As String
  Dim copyhead As Boolean
  Dim lra As Long, lrn As Long
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  sName = "Report"
  On Error Resume Next: Sheets(sName).Delete: On Error GoTo 0
  Sheets.Add(Sheets(1)).Name = sName
  Set shN = Sheets(sName)
  
  Set shS = Sheets("Summary One")
  
  For Each shA In Sheets
    Select Case shA.Name
      Case shS.Name, shN.Name
      
      Case Else
        If shA.AutoFilterMode Then shA.AutoFilterMode = False
      
        If copyhead = False Then
          copyhead = True
          shA.Range("A1:K1").Copy shN.Range("A1")
          With shN.Range("A1:K1")
            .Font.Bold = True
            .Font.Name = "Arial"
            .Font.Size = 11
          End With
        End If
        
        lra = shA.Range("H" & Rows.Count).End(3).Row
        lrn = shN.Range("H" & Rows.Count).End(3).Row + 1
        shA.Range("A1:K" & lra).AutoFilter 8, shS.Range("A2").Value
        shA.Range("A1:K" & lra).AutoFilter 11, shS.Range("A4").Value
        shA.AutoFilter.Range.Range("A2:K" & lra).Copy shN.Range("A" & lrn)
        shA.ShowAllData
    End Select
  Next
  
  shN.Select
  shN.Range("A:B").Font.Color = vbBlack
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

 

[nellyc]

Thank you Dante

- clear any filters first ...Perfect
- Also Columns A&B are white font in the data Still White
- And lastly once the code has finished a Still have the pop up...

 

[DanteAmor]

Also Columns A&B are white font in the data Still White

Did you copy the new code from post #4?
It's very strange. I did another update in the code, please try again.

And lastly once the code has finished a Still have the pop up...

I don't understand, do you want or don't want the message?
It's very simple. I'm going to put the message and if you don't want the message, just delete this line from the macro:

MsgBox "End of the process"

Try with this macro:

Sub ReturnRows()
  Dim shS As Worksheet, shA As Worksheet, shN As Worksheet
  Dim sName As String
  Dim copyhead As Boolean
  Dim lra As Long, lrn As Long
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  sName = "Report"
  On Error Resume Next: Sheets(sName).Delete: On Error GoTo 0
  Sheets.Add(Sheets(1)).Name = sName
  Set shN = Sheets(sName)
 
  Set shS = Sheets("Summary One")
 
  For Each shA In Sheets
    Select Case shA.Name
      Case shS.Name, shN.Name
     
      Case Else
        If shA.AutoFilterMode Then shA.AutoFilterMode = False
     
        If copyhead = False Then
          copyhead = True
          shA.Range("A1:K1").Copy shN.Range("A1")
          With shN.Range("A1:K1")
            .Font.Bold = True
            .Font.Name = "Arial"
            .Font.Size = 11
          End With
        End If
       
        lra = shA.Range("H" & Rows.Count).End(3).Row
        lrn = shN.Range("H" & Rows.Count).End(3).Row + 1
        shA.Range("A1:K" & lra).AutoFilter 8, shS.Range("A2").Value
        shA.Range("A1:K" & lra).AutoFilter 11, shS.Range("A4").Value
        shA.AutoFilter.Range.Range("A2:K" & lra).Copy
        shN.Range("A" & lrn).PasteSpecial xlPasteAll
        shA.ShowAllData
    End Select
  Next
 
  shN.Select
  shN.Range("A:B").Font.Color = vbBlack
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  MsgBox "End of the process"
End Sub

 

[nellyc]

Dante, you have nailed it, thank you so much for your help and patience.