Macros to copy rows from different sheets to a summary sheet

[rmwindham]

Good morning,
I am having a problem with some code I am trying to do. I am new to coding and would love some help. I have multiple sheets that I need data to be pulled from to a summary sheet when the case is over 90 days old, which is column "G", all the sheets are the same, columns A-I, with headers on rows 1-5. I also want it to run automatically when the file is opened, but clear the summary sheet of the rows from last open, so that the data is not duplicated. In addition I want it to paste values only and not formulas. It works to run automatically, but it seems that the pasting of formulas is causing it to paste the wrong rows, which is why I only need values. What I have so far is below. Any help would be greatly appreciated.

Private Sub Workbook_Open()
Dim wsSum As Worksheet: Set wsSum = Sheets("Summary-Cases over 90 Days")
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 > 89 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


Thanks

 

[JLGWhiz]

See if this will work for you.

Private Sub Workbook_Open()
Dim wsSum As Worksheet: Set wsSum = Sheets("Summary-Cases over 90 Days")
Dim ws As Worksheet
Dim rCell As Range
wsSum.Range("A6", wsSum.Cells(Rows.Count, "I").End(xlUp)).ClearContents
    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 > 89 Then
                        rCell.EntireRow.Copy
                        wsSum.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
                    End If
                End If
            Next rCell
        End If
    Next ws
End Sub

 

[rmwindham]

Thank you , that works great, except it starts on line 2 and copies over my headers. I tried a couple tweaks, but could not fix, need it to start on line 6. Any ideas?

 

[JLGWhiz]

Thank you , that works great, except it starts on line 2 and copies over my headers. I tried a couple tweaks, but could not fix, need it to start on line 6. Any ideas?

Your column A on wsSum must be blank. This will fix the paste problem.

Private Sub Workbook_Open()
Dim wsSum As Worksheet: Set wsSum = Sheets("Summary-Cases over 90 Days")
Dim ws As Worksheet, lr As Long
Dim rCell As Range
lr = wsSum.Cells(Rows.Count, 7).End(xlUp).Row
If lr < 6 Then lr = 6
wsSum.Range("A6:I" & lr).ClearContents

    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 > 89 Then
                        rCell.EntireRow.Copy
                        wsSum.Cells(lr, 1).PasteSpecial xlPasteValues
                    End If
                End If
            Next rCell
        End If
    Next ws
End Sub

 

[rmwindham]

No, that didn't work. It now copies everything into 1 row over and over until done and doesn't clear any other rows. Also Column "A" has data on the other sheets.

 

[rmwindham]

I figured it out. Your code works great. Thanks a lot, very much appreciated

 

[JLGWhiz]

I figured it out. Your code works great. Thanks a lot, very much appreciated

Yeah, I got a little hasty on that last reply and forgot to allow for the row offset . Glad you got it going.
Regards, JLG