Extracting records into a Summary worksheet

[Jackster]

I need a little help please.

I have 12 worksheets ( January through December ). Each worksheet is made up of 7 columns ( a record of 7 fields) the last column has the entry of either "Yes" or "No". I am having difficulty creating a macro that will go to each worksheet ( month) and return the records that have a "No" in the last column to my summary page. Can anyone help?

 

[NMeeker]

is your summery page another worksheet within the same workbook?

 

[Trebor76]

Hi Jackster,

Welcome to the forum.

Run the following ConsDataByMonth macro on whatever tab (you'll be asked to confirm) you want the data to be consolidated on. Just note that the code assumes the data starts at row 2 on each sheet:

Sub ConsDataByMonth()

    'Confirm the active tab is where the data is to consolidated.
    If MsgBox("Please click ""Yes"" if the data is to be consolidated on the " _
              & ActiveSheet.Name & " tab.", _
              vbYesNo + vbExclamation, "Data Consolidation Editor") = vbNo Then
        MsgBox "Select the tab you wish to have the data consolidated on and try again." _
            , vbInformation, "Data Consolidation Editor"
    Exit Sub
    End If
    
    Application.ScreenUpdating = False

    'Remove any existing filters
    If ActiveSheet.AutoFilterMode Then
        ActiveSheet.AutoFilterMode = False
    End If

    'Declare variables
    Dim lngLastRow As Long
    Dim wSheet As Worksheet
    Dim rCopy, rPaste As Range
    
    lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    If lngLastRow > 1 Then
        ActiveSheet.Range("A2:G" & lngLastRow).ClearContents
    End If
     
    For Each wSheet In Worksheets
        If wSheet.Name <> ActiveSheet.Name Then
            With wSheet
                Set rCopy = .Range("A2", .Cells(Rows.Count, "G").End(xlUp))
            End With
            Set rPaste = ActiveSheet.Cells(Rows.Count, "A").End(xlUp)(2, 1)
            rCopy.Copy
            rPaste.PasteSpecial Paste:=xlValues, Paste:=xlPasteFormats
            Application.CutCopyMode = False
        End If
    Next wSheet

    With ActiveSheet
        'Set the autofilter
        .Range("A1:G1").AutoFilter
        'Hide all rows that are NOT to be deleted
        .Columns("G").AutoFilter Field:=7, Criteria1:="Yes"
        .Rows("1").EntireRow.Hidden = True
        'Delete all visible data rows in Column G
        .Columns("G").SpecialCells(xlCellTypeVisible).EntireRow.Delete
        'Remove filter from A1:G1
        .AutoFilterMode = False
        'Unhide Row 1.
        .Rows("1").EntireRow.Hidden = False
        'Autofit the dataset
        .Columns("A:G").AutoFit
    End With

    Application.ScreenUpdating = True

    ActiveSheet.Range("A1").Select

End Sub

HTH

Robert

 

[NMeeker]

Well, I guess I am a little late on this one.. but,

Sub Summery()
Dim ws As Worksheet, cel As Range, SumSheet As String
SumSheet = "Sheet1" '****** Change "Sheet1" to name of your summery sheet******
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
    If Not ws.Name = SumSheet Then
        For Each cel In Range("G:G")
            If cel.Value Like "Yes" Or cel.Value Like "yes" Then
                  Call CopyRow(cel.row, ws.Name, SumSheet)
            End If
        Next
    End If
Next
Application.ScreenUpdating = True
End Sub

Sub CopyRow(r As Integer, CurSheet As String, SumSheet As String)
Dim c As Object
    On Error Resume Next
    With Sheets(SumSheet).Range("A:A")
     Set c = .Find(What:="*", LookIn:=xlValues, Lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlPrevious)
    End With
    Worksheets(CurSheet).Rows(r).Copy Destination:=Worksheets(SumSheet).Rows(c.row + 1)
    Worksheets(CurSheet).Rows(r).Delete
End Sub

May be a lil rough... Good luck though

 

[Trebor76]

Hi NMeeker,

I haven't tested it but

May be a lil rough

seems a bit harsh as it looks pretty cool to me

Cheers,

Robert