COUNTA AND COUNTIF in a macro

**itsnick** · 10-28-2009, 10:48 AM

What I'm trying to do is add a line where it counts the number of cells with either the word "NEW" in a certain row (Countif) or the number of cells with a value in a range(Counta). CountA is not working because if I run the macro twice it adds a second total line and messes both the count and total up. COUNTIF I just cant get to work because im a VBA SUPER NOOB and im just pieceing code together from this forum and the net.

Heres an example of what id like to do.

'NEW sheet
    Range("A4").AutoFilter Field:=8, Criteria1:="=NEW*"
    LR = Range("H" & Rows.Count).End(xlUp).Row
        If LR > 1 Then
            Range("A1:Q" & LR).Copy
            Sheets("NEW").Select
            Range("A1").PasteSpecial xlPasteAll
            LR = Range("G" & Rows.Count).End(xlUp).Row + 1
            Range("B" & LR) = "TOTAL"
            Range("E" & LR).FormulaR1C1 = "=SUM(R2C:R" & LR - 1 & "C)"
            Range("F" & LR).FormulaR1C1 = "=SUM(R2C:R" & LR - 1 & "C)"
            Range("H" & LR).FormulaR1C1 = "=COUNTIF DATA,*NEW)"
            Range("A1", "Q" & LR).Borders.Weight = xlThin
            Range("A" & LR, "Q" & LR).Font.Bold = True
            Cells.Columns.AutoFit
            ActiveWindow.DisplayGridlines = False
            Range("A5:Q5").Select
            ActiveWindow.FreezePanes = True
            ws.Activate
        End If

Current version of this macro.

Sub LARGEGROUPUPDATE()
'NBayon (10/21/2009)
Dim LR As Long, ws As Worksheet
Application.ScreenUpdating = False
Set ws = Sheets("ALL")

'Setup
    ws.Activate
    LR = Range("A" & Rows.Count).End(xlUp).Row
    
'NEW sheet
    Range("A4").AutoFilter Field:=8, Criteria1:="=NEW*"
    LR = Range("H" & Rows.Count).End(xlUp).Row
        If LR > 1 Then
            Range("A1:Q" & LR).Copy
            Sheets("NEW").Select
            Range("A1").PasteSpecial xlPasteAll
            LR = Range("G" & Rows.Count).End(xlUp).Row + 1
            Range("B" & LR) = "TOTAL"
            Range("E" & LR).FormulaR1C1 = "=SUM(R2C:R" & LR - 1 & "C)"
            Range("F" & LR).FormulaR1C1 = "=SUM(R2C:R" & LR - 1 & "C)"
            Range("A1", "Q" & LR).Borders.Weight = xlThin
            Range("A" & LR, "Q" & LR).Font.Bold = True
            Cells.Columns.AutoFit
            ActiveWindow.DisplayGridlines = False
            Range("A5:Q5").Select
            ActiveWindow.FreezePanes = True
            ws.Activate
        End If

 'RENEWALS sheet
    Range("A4").AutoFilter Field:=8, Criteria1:="=RWNC*", Operator:=xlOr, Criteria2:="=RWC*"
    LR = Range("H" & Rows.Count).End(xlUp).Row
        If LR > 1 Then
            Range("A1:Q" & LR).Copy
            Sheets("RENEWALS").Select
            Range("A1").PasteSpecial xlPasteAll
            LR = Range("G" & Rows.Count).End(xlUp).Row + 1
            Range("B" & LR) = "TOTAL"
            Range("E" & LR).FormulaR1C1 = "=SUM(R2C:R" & LR - 1 & "C)"
            Range("F" & LR).FormulaR1C1 = "=SUM(R2C:R" & LR - 1 & "C)"
            Range("A1", "Q" & LR).Borders.Weight = xlThin
            Range("A" & LR, "Q" & LR).Font.Bold = True
            Cells.Columns.AutoFit
            ActiveWindow.DisplayGridlines = False
            Range("A5:Q5").Select
            ActiveWindow.FreezePanes = True
            ws.Activate
        End If

 'TERMS sheet
    Range("A4").AutoFilter Field:=8, Criteria1:="=TERM*"
    LR = Range("H" & Rows.Count).End(xlUp).Row
        If LR > 1 Then
            Range("A1:Q" & LR).Copy
            Sheets("TERMS").Select
            Range("A1").PasteSpecial xlPasteAll
            LR = Range("G" & Rows.Count).End(xlUp).Row + 1
            Range("B" & LR) = "TOTAL"
            Range("E" & LR).FormulaR1C1 = "=SUM(R2C:R" & LR - 1 & "C)"
            Range("F" & LR).FormulaR1C1 = "=SUM(R2C:R" & LR - 1 & "C)"
            Range("A1", "Q" & LR).Borders.Weight = xlThin
            Range("A" & LR, "Q" & LR).Font.Bold = True
            Cells.Columns.AutoFit
            ActiveWindow.DisplayGridlines = False
            Range("A5:Q5").Select
            ActiveWindow.FreezePanes = True
            ws.Activate
        End If

'REINSTATEMENTS sheet
    Range("A4").AutoFilter Field:=8, Criteria1:="=REINS*"
    LR = Range("H" & Rows.Count).End(xlUp).Row
        If LR > 1 Then
            Range("A1:Q" & LR).Copy
            Sheets("REINSTATEMENTS").Select
            Range("A1").PasteSpecial xlPasteAll
            LR = Range("G" & Rows.Count).End(xlUp).Row + 1
            Range("B" & LR) = "TOTAL"
            Range("E" & LR).FormulaR1C1 = "=SUM(R2C:R" & LR - 1 & "C)"
            Range("F" & LR).FormulaR1C1 = "=SUM(R2C:R" & LR - 1 & "C)"
            Range("A1", "Q" & LR).Borders.Weight = xlThin
            Range("A" & LR, "Q" & LR).Font.Bold = True
            Cells.Columns.AutoFit
            ActiveWindow.DisplayGridlines = False
            Range("A5:Q5").Select
            ActiveWindow.FreezePanes = True
            ws.Activate
        End If

'CHANGE sheet
    Range("A4").AutoFilter Field:=8, Criteria1:="=CHANGE*"
    LR = Range("H" & Rows.Count).End(xlUp).Row
        If LR > 1 Then
            Range("A1:Q" & LR).Copy
            Sheets("CHANGE").Select
            Range("A1").PasteSpecial xlPasteAll
            LR = Range("G" & Rows.Count).End(xlUp).Row + 1
            Range("B" & LR) = "TOTAL"
            Range("D" & LR).FormulaR1C1 = "=SUM(R2C:R" & LR - 1 & "C)"
            Range("A1", "Q" & LR).Borders.Weight = xlThin
            Range("A" & LR, "Q" & LR).Font.Bold = True
            Cells.Columns.AutoFit
            ActiveWindow.DisplayGridlines = False
            Range("A5:Q5").Select
            ActiveWindow.FreezePanes = True
            ws.Activate
        End If
        
Range("A1").AutoFilter
LR = Range("B" & Rows.Count).End(xlUp).Row + 1
        
 'CERIDIAN sheet
    Range("A4").AutoFilter Field:=15, Criteria1:="=YES*"
    LR = Range("O" & Rows.Count).End(xlUp).Row
        If LR > 1 Then
            Range("A1:Q" & LR).Copy
            Sheets("CERIDIAN").Select
            Range("A1").PasteSpecial xlPasteAll
            Range("A1", "Q" & LR).Borders.Weight = xlThin
            Range("A" & LR, "Q" & LR).Font.Bold = True
            Cells.Columns.AutoFit
            ActiveWindow.DisplayGridlines = False
            Range("A5:Q5").Select
            ActiveWindow.FreezePanes = True
            ws.Activate
        End If
        
Range("A1").AutoFilter
LR = Range("B" & Rows.Count).End(xlUp).Row + 1

Cells.Columns.AutoFit
ActiveWindow.DisplayGridlines = False
Range("A5:Q5").Select
ActiveWindow.FreezePanes = True
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

**itsnick** · 10-28-2009, 03:33 PM

Do I need to clarify anything looking for some help.

**broro183** · 10-28-2009, 05:25 PM

hi,

Here's what the macro recorder gives me for entering the Count functions...

    Range("H30").FormulaR1C1 = "=COUNTIF(R5C8:R29C8,""NEW*"")"
    Range("H30").FormulaR1C1 = "=COUNTA(R5C8:R29C8)"
'which can be modified to
Range("H30").FormulaR1C1 = "=COUNTIF(R5C8:R" & LR & "C8,""NEW*"")"
Range("H30").FormulaR1C1 = "=COUNTA(R5C8:R" & LR & "C8)"

but then comes your comment "if I run the macro a second time"...

Do you need to keep the totals separate each time the macro is run?
If not, I strongly recommend moving the total cells to above the header row (& using a dynamic named range). This means the total becomes part of the original design & doesn't need to be modifed each time the macro is run.
If you do, you could try this approach:

Range("H30").FormulaR1C1 = "=COUNTA(R5C8:R29C8)-SUMIF(R5C2:R29C2,""TOTAL"",R5C8:R29C8)"
'which can be modified to
Range("H30").FormulaR1C1 = "=COUNTA(R5C8:R" & LR & "C8)-SUMIF(R5C2:R" & LR & "C2,""TOTAL"",R5C8:R" & LR & "C8)"

hth
Rob

**broro183** · 10-28-2009, 06:14 PM

hi again,

I've played around a little & have come up with the below (please note that I haven't thoroughly tested it). Also, I haven't included all your formatting code but I think you'll be able to add this into the right place. :-)

Option Explicit

Sub FilterAndCopyByGroupings()
Const HdrRw As Long = 4
Dim LR As Long
Dim i As Long
Dim StatusStrToFilterArr As Variant
Dim ShtsArr As Variant
Dim FilterFldArr As Variant
Dim DestRng As Range
Dim RngToCopy As Range
Dim FirstBlankRw As Long
    Application.ScreenUpdating = False
    StatusStrToFilterArr = Array("=NEW*", "=RW*", "=TERM*", "=REINS*", "=CHANGE*", "=YES*")
    FilterFldArr = Array(8, 8, 8, 8, 8, 15)
    With ThisWorkbook
        Set ShtsArr = .Worksheets(Array("NEW", "RENEWALS", "TERMS", "REINSTATEMENTS", "CHANGE", "CERIDIAN"))
        With .Worksheets("ALL")
            With .Range(.Cells(HdrRw, 1), LastCell(Worksheets("ALL")))
                'test if a filter is on the sheet & remove - just in case it is incorrectly sized
                If .Parent.FilterMode Then .AutoFilter
'reapply the autofilter to the correct range
.autofilter
                'loop through the criteria
                For i = LBound(StatusStrToFilterArr) To UBound(StatusStrToFilterArr)
                    .AutoFilter Field:=FilterFldArr(i), Criteria1:=StatusStrToFilterArr(i)
                    'in case there are no visible rows
                    On Error Resume Next
                    With ShtsArr(i + 1)
                        FirstBlankRw = LastCell(CVar(ShtsArr(i + 1))).Row + 1
                        Set DestRng = .Cells(FirstBlankRw, 1)
                    End With
                    Set RngToCopy = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).SpecialCells(xlCellTypeVisible)
                    ''copy the data rows to the appropriate sheet
                    'Application.Goto DestRng 'for testing
                    'Application.Goto RngToCopy 'for testing
                    RngToCopy.Copy DestRng
                    With ShtsArr(i + 1)
                        FirstBlankRw = LastCell(CVar(ShtsArr(i + 1))).Row + 1
'### you may want to change these to the suggestion in my previous post
                        .Range("B" & FirstBlankRw) = "TOTAL"
                        .Range("E" & FirstBlankRw).FormulaR1C1 = "=SUM(R2C:R" & FirstBlankRw - 1 & "C)"
                        .Range("F" & FirstBlankRw).FormulaR1C1 = "=SUM(R2C:R" & FirstBlankRw - 1 & "C)"
                    End With
                    Set DestRng = Nothing
                    Set RngToCopy = Nothing
                    On Error GoTo 0
                    .AutoFilter Field:=FilterFldArr(i)
                Next i
                .AutoFilter
            End With
        End With
    End With
    Set ShtsArr = Nothing
    Application.ScreenUpdating = True
End Sub

Function LastCell(ws As Worksheet) As Range
' sourced from http://www.beyondtechnology.com/geeks012.shtml
'to identify the lastcell on a worksheet (& not necessarily the active sheet)
Dim LastRow As Long
Dim LastCol As Long
    ' Error-handling is here in case there is not any
    ' data in the worksheet
    On Error Resume Next
    With ws
        ' Find the last real row
        LastRow = .Cells.Find(What:="*", _
                              SearchDirection:=xlPrevious, _
                              SearchOrder:=xlByRows).Row
        LastRow = Application.WorksheetFunction.Max(1, LastRow)
        ' Find the last real column
        LastCol = .Cells.Find(What:="*", _
                              SearchDirection:=xlPrevious, _
                              SearchOrder:=xlByColumns).Column
        LastCol = Application.WorksheetFunction.Max(1, LastCol)
    End With
    On Error GoTo 0
    ' Finally, initialize a Range object variable for
    ' the last populated row.
    Set LastCell = ws.Cells(LastRow, LastCol)
End Function

hth
Rob

**itsnick** · 10-29-2009, 09:06 AM

Rob,

Thanks for all your help it seems this changed the format/style of my current macro and I was able to merge the two. I see what you did with the totals and that works grea, but im going to go with your suggestion and create a totals area. It just makes more sense, for those reading this regarding the countif or counta, I added a seperate summary sheet with the a simple countif formula. Once again thank you for your help.

**broro183** · 10-29-2009, 04:51 PM

hi Nick,

Thanks for the feedback - I'm pleased I could help

I'm stoked you went with my suggestion for changing your file layout because (although we can modify macros) I think it is much easier to maintain a consistent header row area.

Would you mind posting your completed file in case others are searching the thread?

Feel free to add to my reputation by clicking on the blue scales at the top of my post - it is appreciated

Rob