Count if for excel VBA, and printing results in another range

Question

I have a list of about 12,000 lines, with project numbers, account managers, create date, status... and so on.. Currently I am making reports every 2 weeks, as pivot tables, and then I make graphs out of them. I know that this can be automated, as I eliminated the pivot tables and replicated the result with countifs. Now I want to be able to do the same thing with VBA, to the point where a user can go in a spreadsheet, hit a button and the most current data will portray. To start with this, I want to explore a little bit of countif in vba.

Let's say that the table looks like this

 A          |         B       |    C
proj.Number   Account Manager   Status
   123            Person 1       Won
   234            Person 2       Lost
   345            Person 3       Quoted

Currently this is my code, that works fine for countif, but it's without a loop... and I know it can be done somehow

 Dim PersonOne as Range
    Set PersonOne = Range("E2")
 Dim PersonTwo as Range
    Set PersonTwo = Range("E3") 
 Dim PersonThree as Range
    Set PersonThree = Range("E4")

        Range("D2") = "Person 1"
        Range("D3") = "Person 2"
        Range("D4") = "Person 3"

PersonOne = (WorksheetFunction.CountIf(Range("B2", Range("B2").End(xlDown)), "Person 1"))   
PersonTwo = (WorksheetFunction.CountIf(Range("B2", Range("B2").End(xlDown)), "Person 2"))  
PersonThree = (WorksheetFunction.CountIf(Range("B2", Range("B2").End(xlDown)), "Person 3")) 

How do I automate this, to the point that I don't even have to write the names of the people (the part where I say range(d2) = some person Can I have a code that looks for all possible unique names, puts them in a certain range of a spreadsheet, and than count how many times that name occurs in the given range?

Thank you

Answer 1

That's how you can apply it only using Pivot Table:

First: Insert Pivot Table/Chart

Insert a pivot table with all the columns that you want:

Second: Filter Blanks

Then you can add your desired field to the pivot table. Add one of the columns as filter to ignore blanks:

Third: Append Data

Later you can append data at the bottom of your table:

Fourth: Refresh

Refresh the workbook:

And you're all set:

Answer 2

The below code and function should do what you need. Although it currently prints to column D and E on the same page but you can easily change that if you want it somewhere else.

Sub CountIF()

    Dim wbk As Workbook
    Dim ws As Worksheet
    Dim myNames() As String
    Dim lRow As Long, x As Long
    Dim Cell As Range
    Dim Test As Boolean

    Set wbk = Workbooks("Book1.xlsm") 'Change this to your workbook name
    Set ws = wbk.Worksheets("Sheet1") 'Change this to your worksheet name

    ReDim myNames(0 To 0) As String

    With ws
        lRow = .Range("B" & .Rows.Count).End(xlUp).Row
        'Loop through Column B and populate array
        For Each Cell In .Range(.Cells(2, "B"), .Cells(lRow, "B"))
            'Check if Name is already in array
            Test = IsInArray(Cell.Value, myNames) > -1
            If Test = False Then
                'Insert name into array
                myNames(UBound(myNames)) = Cell.Value
                ReDim Preserve myNames(0 To UBound(myNames) + 1) As String
            End If
        Next Cell

        ReDim Preserve myNames(0 To UBound(myNames) - 1) As String
        'Print title in D and value in E
        For x = LBound(myNames) To UBound(myNames)
            'Use x + 1 because our array starts at 0
            .Cells(x + 1, "D").Value = myNames(x)
            .Cells(x + 1, "E").Value = WorksheetFunction.CountIF(.Range(.Cells(2, "B"), .Cells(lRow, "B")), myNames(x))
        Next x
    End With

    Erase myNames

End Sub

The code uses this function so be sure to include it

Function IsInArray(stringToBeFound As String, arr As Variant) As Long
'http://stackoverflow.com/questions/10951687/how-to-search-for-string-in-an-array
'Boolean = (IsInArray(StringToFind, ArrayToSearch) > -1)
    Dim i As Long
    ' default return value if value not found in array
    IsInArray = -1

    For i = LBound(arr) To UBound(arr)
        If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
            IsInArray = i
            Exit For
        End If
    Next i
End Function

Answer 3

A bit late, but if you Record Macro of Data > Consolidate, you get something like:

Range("E1").Consolidate Sources:=Range("B:C").Address(, , xlR1C1, 1), Function:=xlCount, _
                        TopRow:=True, LeftColumn:=True, CreateLinks:=False