VBA to copy a row from multiple tabs to a summary tab based on criteria met

R

rmwindham

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

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand
Sort by date Sort by votes
Code: 
Sub Macro1()
sht1 = "Sheet1"
sht2 = "Sheet2"
sht2DataStart = 1
numRow = 1 'used to keep track of what row number in sht2 it's currently on in the Loop
newRow = 1 'used to keep track of where to enter the new row in sht1
clearSht = Sheets(sht1).Range("G" & Rows.Count).End(xlUp).Row
Sheets(sht1).Range("A" & newRow & ":I" & clearSht).ClearContents
lastRow = Sheets(sht2).Range("G" & Rows.Count).End(xlUp).Row
    For Each cell In Sheets(sht2).Range("G" & sht2DataStart & ":G" & lastRow).Value
        If Sheets(sht2).Range("G" & numRow).Value > 90 Then
            Sheets(sht1).Range("A" & newRow).Value = Sheets(sht2).Range("A" & numRow).Value
            Sheets(sht1).Range("B" & newRow).Value = Sheets(sht2).Range("B" & numRow).Value
            Sheets(sht1).Range("C" & newRow).Value = Sheets(sht2).Range("C" & numRow).Value
            Sheets(sht1).Range("D" & newRow).Value = Sheets(sht2).Range("D" & numRow).Value
            Sheets(sht1).Range("E" & newRow).Value = Sheets(sht2).Range("E" & numRow).Value
            Sheets(sht1).Range("F" & newRow).Value = Sheets(sht2).Range("F" & numRow).Value
            Sheets(sht1).Range("G" & newRow).Value = Sheets(sht2).Range("G" & numRow).Value
            Sheets(sht1).Range("H" & newRow).Value = Sheets(sht2).Range("H" & numRow).Value
            Sheets(sht1).Range("I" & newRow).Value = Sheets(sht2).Range("I" & numRow).Value
            newRow = newRow + 1
        End If
        numRow = numRow + 1
    Next
End Sub
 
Upvote 0
Thanks for the help, only it seems your code has sheet1 which I assume is the Summary and sheet2, mine has about 20 sheets, and then a Summary sheet. I am not sure how to adapt your code for all the sheets in my workbook
 
Upvote 0
This code works. There is only 1 catch. If a worksheet doesn't exist, it brings back an error. I can't figure out how to bypass it. So you'll have to tell the code how many worksheets you have and what the names of them are. Any mistake there and the entire thing crashes.

Code: 
Sub Macro1()
[COLOR=#ff0000]  sht1 = "Sheet1" [/COLOR][COLOR=#008000]'Summary Sheet[/COLOR][COLOR=#ff0000]
    sht2 = "Sheet2"
    sht3 = "Sheet3"
    sht4 = "Sheet4"
    sht5 = "Sheet5"
    sht6 = "Sheet6"
    sht7 = "Sheet7"
    sht8 = "Sheet8"
    sht9 = "Sheet9"
    sht10 = "Sheet10"
    sht11 = "Sheet11"
    sht12 = "Sheet12"
    sht13 = "Sheet13"
    sht14 = "Sheet14"
    sht15 = "Sheet15"
    sht16 = "Sheet16"
    sht17 = "Sheet17"
    sht18 = "Sheet18"
    sht19 = "Sheet19"
    sht20 = "Sheet20"
    sht21 = "Sheet21"[/COLOR]
    shtCounter = 1 [COLOR=#008000]'used to keep track of which sheet it is currently looping through.[/COLOR]
    [COLOR=#ff0000]totalSheets = 21[/COLOR] [COLOR=#008000]'this is the number of sheets you are searching through including the summary sheet.[/COLOR]
    
    
    newRow = 1 [COLOR=#008000]'used to keep track of where to enter the new row in sht1.[/COLOR]
    clearSht = Sheets(sht1).Range("G" & Rows.Count).End(xlUp).Row
    Sheets(sht1).Range("A" & newRow & ":I" & clearSht).ClearContents
    Do While shtCounter < totalSheets
        If shtCounter = 1 Then
            shtName = sht2
        End If
        If shtCounter = 2 Then
            shtName = sht3
        End If
        If shtCounter = 3 Then
            shtName = sht4
        End If
        If shtCounter = 4 Then
            shtName = sht5
        End If
        If shtCounter = 5 Then
            shtName = sht6
        End If
        If shtCounter = 6 Then
            shtName = sht7
        End If
        If shtCounter = 7 Then
            shtName = sht8
        End If
        If shtCounter = 8 Then
            shtName = sht9
        End If
        If shtCounter = 9 Then
            shtName = sht10
        End If
        If shtCounter = 10 Then
            shtName = sht11
        End If
        If shtCounter = 11 Then
            shtName = sht12
        End If
        If shtCounter = 12 Then
            shtName = sht13
        End If
        If shtCounter = 13 Then
            shtName = sht14
        End If
        If shtCounter = 14 Then
            shtName = sht15
        End If
        If shtCounter = 15 Then
            shtName = sht16
        End If
        If shtCounter = 16 Then
            shtName = sht17
        End If
        If shtCounter = 17 Then
            shtName = sht18
        End If
        If shtCounter = 18 Then
            shtName = sht19
        End If
        If shtCounter = 19 Then
            shtName = sht20
        End If
        If shtCounter = 20 Then
            shtName = sht21
        End If
        sht2DataStart = 1
        numRow = 1 [COLOR=#008000]'used to keep track of what row number in sht2 and other lookup sheets it's currently on in the Loop.[/COLOR]
        If IsError(Sheets(shtName).Range("G" & Rows.Count).End(xlUp).Row) Then 'TEST
        ElseIf Sheets(shtName).Range("G" & Rows.Count).End(xlUp).Row = 1 Then 'TEST
            If Sheets(shtName).Range("G" & numRow).Value > 90 Then
                Sheets(sht1).Range("A" & newRow).Value = Sheets(shtName).Range("A" & numRow).Value
                Sheets(sht1).Range("B" & newRow).Value = Sheets(shtName).Range("B" & numRow).Value
                Sheets(sht1).Range("C" & newRow).Value = Sheets(shtName).Range("C" & numRow).Value
                Sheets(sht1).Range("D" & newRow).Value = Sheets(shtName).Range("D" & numRow).Value
                Sheets(sht1).Range("E" & newRow).Value = Sheets(shtName).Range("E" & numRow).Value
                Sheets(sht1).Range("F" & newRow).Value = Sheets(shtName).Range("F" & numRow).Value
                Sheets(sht1).Range("G" & newRow).Value = Sheets(shtName).Range("G" & numRow).Value
                Sheets(sht1).Range("H" & newRow).Value = Sheets(shtName).Range("H" & numRow).Value
                Sheets(sht1).Range("I" & newRow).Value = Sheets(shtName).Range("I" & numRow).Value
                newRow = newRow + 1
            End If
        Else
        lastRow = Sheets(shtName).Range("G" & Rows.Count).End(xlUp).Row
        For Each cell In Sheets(shtName).Range("G" & sht2DataStart & ":G" & lastRow).Value
            If Sheets(shtName).Range("G" & numRow).Value > 90 Then
                Sheets(sht1).Range("A" & newRow).Value = Sheets(shtName).Range("A" & numRow).Value
                Sheets(sht1).Range("B" & newRow).Value = Sheets(shtName).Range("B" & numRow).Value
                Sheets(sht1).Range("C" & newRow).Value = Sheets(shtName).Range("C" & numRow).Value
                Sheets(sht1).Range("D" & newRow).Value = Sheets(shtName).Range("D" & numRow).Value
                Sheets(sht1).Range("E" & newRow).Value = Sheets(shtName).Range("E" & numRow).Value
                Sheets(sht1).Range("F" & newRow).Value = Sheets(shtName).Range("F" & numRow).Value
                Sheets(sht1).Range("G" & newRow).Value = Sheets(shtName).Range("G" & numRow).Value
                Sheets(sht1).Range("H" & newRow).Value = Sheets(shtName).Range("H" & numRow).Value
                Sheets(sht1).Range("I" & newRow).Value = Sheets(shtName).Range("I" & numRow).Value
                newRow = newRow + 1
            End If
            numRow = numRow + 1
        Next
        End If 'TEST
        shtCounter = shtCounter + 1
    Loop
End Sub
You can delete all the parts where it says 'TEST
I was obviously testing lines of code to see if they worked. I forgot to delete the word TEST after it worked.
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
Copying Data To A New Sheet, Based On A Specific Week's Data
Replies
6
Views
296
Snakehips
Snakehips
T
  • Question
Prevent cell references from changing after inserting rows or columns
Replies
2
Views
196
kvsrinivasamurthy
K
T
  • Solved
VBA: Search in column for specific text and copy to another tab
2
Replies
12
Views
443
TaskMaster
T
H
  • Solved
Move rows from pending to completed tab
2
Replies
15
Views
490
My Aswer Is This
My Aswer Is This
Y
  • Question
VBA Code to activate the tab and and transfer data
Replies
1
Views
111
Joe4
Joe4

Forum statistics

Threads
1,221,122
Messages
6,158,061
Members
451,461
Latest member
Rayc266

Share this page

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