VBA - Return all rows based on two criteria

nellyc

New Member
Joined
Mar 22, 2023
Messages
8
Office Version
  1. 2010
Platform
  1. Windows
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?
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
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:
VBA Code:
sName = "Report"


Full macro:

VBA Code:
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
--------------
 
Upvote 0
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 :)
 
Upvote 0
- 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:

VBA Code:
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
 
Upvote 0
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...
 
Upvote 0
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:
VBA Code:
MsgBox "End of the process"

Try with this macro:
VBA Code:
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
 
Upvote 1
Solution

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top