Macros to copy rows from different sheets to a summary sheet

rmwindham

New Member
Joined
Mar 17, 2014
Messages
17
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
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
See if this will work for you.
Code:
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
 
Upvote 0
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?
 
Upvote 0
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.
Code:
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
 
Last edited:
Upvote 0
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.
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,213,513
Messages
6,114,072
Members
448,546
Latest member
KH Consulting

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