Code to copy a row from multiple sheets to a summary sheet per criteria

[rmwindham]

Hello,
I need some help with some code to copy a row of data from multiple tabs to a summary tab. What I have is a worksheet with several tabs, all formatted the same, in column G, there is a calculation of the number of days a case has been open, when that data gets to be >90, I need that row, column A to I to copy to the next empty row on the "Summary" tab. I have looked on here and found some similar scenarios, but none seem to work for what I want. Any help will be appreciated. Thanks

[trisoldee]

I just posted this for someone else with a very similar issue. There's probably another way to do what you're asking but this will basically merge all sheets to one and then sort Descending by column G. You'd then just have to delete everything else that you don't want which I'm sure there's a way to add to the macro.

Sub MergeSheets()
'''''''''''''''''''''''''''''''''''''''''''''''''
'Copy data from all Worksheets to a new Worksheet
'''''''''''''''''''''''''''''''''''''''''''''''''
Dim intI, intSheetsCount As Integer
Dim blnFirstCopyComplete As Boolean
Dim NewSheet As Worksheet
Dim rngRange As Range
Dim lngLastRow
'Create a new Worksheet and move it before all Worksheets
Set NewSheet = ActiveWorkbook.Worksheets.Add(Before:=Worksheets(1))
'Get the number of Worksheets
intSheetsCount = ActiveWorkbook.Worksheets.Count
'Excluding the new Worksheet, copy all other Worksheets
'one by one
For intI = 2 To intSheetsCount
   
   'This is the Range that will be copied to the new Worksheet
   With ActiveWorkbook.Worksheets(intI)
      Set rngRange = .Range(.Cells(1, 1), _
         .Cells.SpecialCells(xlCellTypeLastCell))
   End With
   
   With NewSheet
      'If this is the first paste, do it on the first row
      If Not blnFirstCopyComplete Then
         rngRange.Copy Destination:=.Cells(1, 1)
         blnFirstCopyComplete = True
      'Else, first find the cell where the copied range will be
      'pasted and proceed with the paste
      Else
         'This is last row of the so far created new Worksheet data
         lngLastRow = .Range(.Cells(1, 1), _
            .Cells.SpecialCells(xlCellTypeLastCell)).Rows.Count
         'Do the paste on the next row
         rngRange.Copy Destination:=.Cells(lngLastRow + 1, 1)
      End If
   End With
Next 'intI

    ActiveSheet.Name = "Summary"
    Worksheets("Summary").Columns("a:i").AutoFit
    Cells.Select
    ActiveWorkbook.Worksheets("Summary").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Summary").Sort.SortFields.Add Key:=Range("g2:g500000") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Summary").Sort
        .SetRange Range("A1:i500000")
        .HEADER = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

[stnkynts]

Assuming you have headers in row 1:

Sub Consolidate_90Days()
Dim wsSum As Worksheet:   Set wsSum = Sheets("Summary") 'make sure this matches your summary sheet name
Dim ws As Worksheet

For Each ws In Worksheets
    If ws.Name <> wsSum.Name Then
        With ws
            .AutoFilterMode = False
            .Range("G1:G" & .Range("G" & Rows.Count).End(xlUp).Row).AutoFilter Field:=1, Criteria1:=">" & 90
            .AutoFilter.Range.Offset(1, 0).EntireRow.Copy Destination:=wsSum.Range("G" & Rows.Count).End(xlUp).Offset(1, -6)
            .AutoFilterMode = False
        End With
    End If
Next ws
    
End Sub

[rmwindham]

Thanks for the help, but I get a "Run-Time error 1004" code.

Sub Consolidate_90Days()
Dim wsSum As Worksheet: Set wsSum = Sheets("Summary") 'make sure this matches your summary sheet name
Dim ws As Worksheet

The sheet name is "Summary"; How exactly do I need the second line of code to be? Do I need to change any other lines? Sorry for the questions, but I am new to coding and trying to work my way thru it.

[Solus Rankin]

Is there a trailing space at the end of your sheet name? "Summary "?

[rmwindham]

No there isn't

[Solus Rankin]

I could not replicate the problem. Can you attach your workbook?

[rmwindham]

Sure, here it is and thanks

[stnkynts]

No workbook attached

[rmwindham]

How about now? It shows in Go Advanced, manage attachments. Am I doing it correctly?

[stnkynts]

Nope. You probably need to click the insert inline or done button after you select the workbook. You will be able to see it in your post when you do

[rmwindham]

Now Attached

[rmwindham]

Wrong file, last one had no sample data, this one has data

[stnkynts]

Sheet name needs to match.

But that is not going to be your only issue.

[stnkynts]

Please also note that your columns in the summary sheet do not line up with the others sheets. You will need to add a column A

Sub Consolidate_90Days()
Dim wsSum As Worksheet:   Set wsSum = Sheets("Summary-Cases over 90 Days") 'make sure this matches your summary sheet name
Dim ws As Worksheet
Dim rCell As Range

For Each ws In Worksheets
    If ws.Name <> wsSum.Name And ws.Name <> "DropDowns" Then
        For Each rCell In ws.Range("G5:G" & ws.Range("G" & Rows.Count).End(xlUp).Row)
            If rCell.Value <> "" And IsNumeric(rCell.Value) Then
                If rCell.Value > 90 Then
                    rCell.EntireRow.Copy Destination:=wsSum.Range("G" & Rows.Count).End(xlUp).Offset(1, -6)
                End If
            End If
        Next rCell
    End If
Next ws
    
End Sub

[rmwindham]

Thanks very much. There is a Column A, it is hidden on the data pages. Only need it to show on the Summary page. Your code is very close, but shows some rows that are less than 90 days and doesn't show all of the rows that are over 90 days. I will tinker with it. Thanks again