none
Loop thru sheets and Create Summary Sheet RRS feed

  • Question

  • I have a workbook with miltiple sheets of schedule data. I am trying to loop thru each sheet and copy a row to summary sheet if column O = "Y". When done i need a summary sheet of all rows in all sheets where column O = "Y". Can someone help me with this? Thanks
    Wednesday, February 27, 2013 4:13 PM

Answers

  • Run this sub. I have assumed that all sheets have headers in row 1 and are filled from column A over

    Sub MakeSummary()

        Dim strName As String
        strName = "Summary"

        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets(strName).Delete
        Application.DisplayAlerts = True

        Worksheets(1).Copy Before:=Worksheets(1)
        Worksheets(1).Name = strName
        For i = 3 To Worksheets.Count
            With Worksheets(i)
                .Range(.Range("A2"), .Cells(.Rows.Count, "O").End(xlUp)).EntireRow.Copy _
                        Worksheets(strName).Cells(Worksheets(strName).Rows.Count, "A").End(xlUp)(2)
            End With
        Next i

        With Worksheets("Summary")
            .Cells.Sort Key1:=.Range("O2"), Order1:=xlAscending, Header:=xlYes
            .Cells.AutoFilter Field:=15, Criteria1:="<>Y", Operator:=xlAnd
            .Rows("2:" & .Rows.Count).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .Cells.AutoFilter
            .Cells.Sort Key1:=.Range("O2"), Order1:=xlAscending, Header:=xlYes
        End With

    End Sub


    Wednesday, February 27, 2013 4:36 PM

All replies

  • Run this sub. I have assumed that all sheets have headers in row 1 and are filled from column A over

    Sub MakeSummary()

        Dim strName As String
        strName = "Summary"

        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets(strName).Delete
        Application.DisplayAlerts = True

        Worksheets(1).Copy Before:=Worksheets(1)
        Worksheets(1).Name = strName
        For i = 3 To Worksheets.Count
            With Worksheets(i)
                .Range(.Range("A2"), .Cells(.Rows.Count, "O").End(xlUp)).EntireRow.Copy _
                        Worksheets(strName).Cells(Worksheets(strName).Rows.Count, "A").End(xlUp)(2)
            End With
        Next i

        With Worksheets("Summary")
            .Cells.Sort Key1:=.Range("O2"), Order1:=xlAscending, Header:=xlYes
            .Cells.AutoFilter Field:=15, Criteria1:="<>Y", Operator:=xlAnd
            .Rows("2:" & .Rows.Count).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .Cells.AutoFilter
            .Cells.Sort Key1:=.Range("O2"), Order1:=xlAscending, Header:=xlYes
        End With

    End Sub


    Wednesday, February 27, 2013 4:36 PM
  • Thanks Bernie it worked. I forgot to ask about putting the sheet name in last column. Is this possible?
    Wednesday, February 27, 2013 4:51 PM
  • Anything is possible:

    Sub MakeSummary2()

        Dim strName As String
        Dim iNameCol As Integer
        strName = "Summary"

        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets(strName).Delete
        Application.DisplayAlerts = True

        Worksheets(1).Copy Before:=Worksheets(1)
        With Worksheets(1)
            .Name = strName
            iNameCol = .Cells(1, .Columns.Count).End(xlToLeft)(1, 2).Column
            .Cells(1, iNameCol).Value = "Sheet Name"
            .Range(.Cells(.Rows.Count, iNameCol).End(xlUp)(2), _
                .Cells(.Rows.Count, iNameCol - 1).End(xlUp)(1, 2)).Value = Worksheets(2).Name
        End With
       
        For i = 3 To Worksheets.Count
            With Worksheets(i)
                .Range(.Range("A2"), .Cells(.Rows.Count, "A").End(xlUp)).EntireRow.Copy _
                        Worksheets(strName).Cells(Worksheets(strName).Rows.Count, "A").End(xlUp)(2)
            End With
            With Worksheets(strName)
                .Range(.Cells(.Rows.Count, iNameCol).End(xlUp)(2), _
                .Cells(.Rows.Count, iNameCol - 1).End(xlUp)(1, 2)).Value = Worksheets(i).Name
            End With
        Next i

        With Worksheets("Summary")
            .Cells.Sort Key1:=.Range("O2"), Order1:=xlAscending, Header:=xlYes
            .Cells.AutoFilter Field:=15, Criteria1:="<>Y", Operator:=xlAnd
            .Rows("2:" & .Rows.Count).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .Cells.AutoFilter
            .Cells.Sort Key1:=.Range("O2"), Order1:=xlAscending, Header:=xlYes
        End With

    End Sub

    Wednesday, February 27, 2013 5:22 PM
  • Thanks! That worked for sheet name but for some reason it is not adding last 10 sheets to summary
    Wednesday, February 27, 2013 5:55 PM
  • I changed i = 14 and it seem to have worked. Thank You
    Wednesday, February 27, 2013 6:05 PM
  • Is column A filled on those last ten sheets? That's what I am using to find the values, and to find where to paste the data. If column A is not filled, then it requires different code (obviously). Also, those rows could be deleted if column O does not contain any Y values (say, because it was shifted over on those sheets and is now column P).

    Wednesday, February 27, 2013 6:07 PM
  • Where was i = 14?
    Wednesday, February 27, 2013 6:16 PM
  • What i changed did not work it skipped some sheets up front but did go all the way to end. All column A is filled and all column O containe "Y" or "N". by adjusting the i=3 to i=14 it did pick up sheets that it did not before but skipped some it did have?

    Wednesday, February 27, 2013 6:25 PM
  • How much data does each sheet have - if the total rows goes beyond 65K (for Excel 2003) then it won't work - I filter after compiling all the data, so we could delete rows after each addition - is that the case? So try this instead:

    Sub MakeSummary2()

        Dim strName As String
        Dim iNameCol As Integer
        strName = "Summary"

        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets(strName).Delete
        Application.DisplayAlerts = True

        Worksheets(1).Copy Before:=Worksheets(1)
        With Worksheets(1)
            .Name = strName
            iNameCol = .Cells(1, .Columns.Count).End(xlToLeft)(1, 2).Column
            .Cells(1, iNameCol).Value = "Sheet Name"
            .Range(.Cells(.Rows.Count, iNameCol).End(xlUp)(2), _
                .Cells(.Rows.Count, iNameCol - 1).End(xlUp)(1, 2)).Value = Worksheets(2).Name
        End With
       
        For i = 3 To Worksheets.Count
            With Worksheets(i)
                .Range(.Range("A2"), .Cells(.Rows.Count, "A").End(xlUp)).EntireRow.Copy _
                        Worksheets(strName).Cells(Worksheets(strName).Rows.Count, "A").End(xlUp)(2)
            End With
            With Worksheets(strName)
                .Range(.Cells(.Rows.Count, iNameCol).End(xlUp)(2), _
                .Cells(.Rows.Count, iNameCol - 1).End(xlUp)(1, 2)).Value = Worksheets(i).Name
             .Cells.Sort Key1:=.Range("O2"), Order1:=xlAscending, Header:=xlYes
            .Cells.AutoFilter Field:=15, Criteria1:="<>Y", Operator:=xlAnd
            .Rows("2:" & .Rows.Count).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .Cells.AutoFilter
            .Cells.Sort Key1:=.Range("O2"), Order1:=xlAscending, Header:=xlYes
        End With

    Next i

    End Sub


    Wednesday, February 27, 2013 7:00 PM
  • Thanks that seemed to worked. It is 2010 but a lot of data. 40+ sheets with 2k rows.

    Wednesday, February 27, 2013 7:25 PM
  • "Seemed to work" is worrisome - you should do the process manually to make sure that what you get from the macro is the same. The checking that I did on a data set that I created showed that it worked, but there may be something odd about the data or the structure of your workbook that makes the code not work perfectly - like some of your Y values being padded with spaces, blanks in an odd place, etc.
    Wednesday, February 27, 2013 8:39 PM
  • I checked it all and it worked fine. Thanks alot for your help.

    Thursday, February 28, 2013 1:53 AM