Solved: Count the same items in a column

[sasa]

Good Morning,
I have a table with three columns and one item every four rows. What I need is a routine that counts the same item of every column and give me the result
column by column.

Here is my example
thanks in advance

sasa

[Bob Phillips]

Don't you just want something like

=COUNTIF(B:B,"Mazzoni")

[sasa]

yes...thanks..
But there is not a way to make the same thing by a macro ?

[lucas]

[VBA]Option Explicit
Sub CountMazzoni()
Dim i As Long
Dim cPast As Long
'change the 2 to Cells to any number to start on a different row
For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
If Cells(i, "B").Value = "Mazzoni" Then
cPast = cPast + 1
End If
Next i
MsgBox "Mazzoni found " & cPast & " Times in Column B"
Range("B128").Value = "Mazzoni = " & cPast
End Sub
[/VBA]

[Bob Phillips]

[vba]

[vba]

Public Sub ProcessData()
Dim i As Long, j As Long
Dim LastRow As Long
Dim LastRow1 As Long
Dim NextRow As Long
Dim colValues As Collection
Dim itm

With ActiveSheet

LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
LastRow1 = .Cells(.Rows.Count, "C").End(xlUp).Row
If LastRow1 > LastRow Then LastRow = LastRow1
LastRow1 = .Cells(.Rows.Count, "D").End(xlUp).Row
If LastRow1 > LastRow Then LastRow = LastRow1
For j = 2 To 4

On Error Resume Next
Set colValues = New Collection
For i = 1 To LastRow

If Trim(.Cells(i, j).Value) <> "" Then _
colValues.Add CStr(.Cells(i, j).Value), CStr(.Cells(i, j).Value)
Next i
On Error GoTo 0

NextRow = LastRow + 15
For Each itm In colValues

.Cells(NextRow, j).Value = itm & "=" & Application.CountIf(.Cells(1, j).Resize(LastRow), itm)
NextRow = NextRow + 1
Next itm
Next j
End With

End Sub
[/vba]

[sasa]

Thanks, the last macro is just what I needed. Is it possible to have the same names on the same row and an added row withe the final sum ?
Example: Di Pietro = 4 Di Pietro = 2 Di Pietro = 5 Di Pietro Sum = 11
Parisi = 1 Parisi = 2 Parisi = 1 Parisi Sum = 4
and so on

Thanks

[sasa]

Any help ?

[sasa]

Pls, if no help I can close this thread as solved.

[GTO]

Could you attach a small sample wb w/before and after?

[sasa]

in the attached file there is what I need

sasa

[GTO]

Greetings,

If your range is or later becomes extremely large, I would think this could slow down a bit.

I found that at least in your sample data, let's say 'Damiani', in one column there would be a trailing space for ea entry. In the other columns not. While this circumstance gave the "correct" answer, this seems spotty, so I trimmed before anything else. The other thing that could slow it is the bubblesort.

Well, see what you think:

Option Explicit
    
Sub GetStats()
Dim _
wks         As Worksheet, _
rngData     As Range, _
rCell       As Range, _
lLeftCol    As Long, _
lRightCol   As Long, _
lTopRow     As Long, _
lBotRow     As Long, _
x           As Long, _
y           As Long, _
i           As Long, _
lRunTot     As Long, _
aryRaw      As Variant, _
aryData     As Variant, _
COL         As Collection
    
    Set wks = ActiveSheet
            
    If Not RangeFound(wks.Cells, , wks.Cells(Rows.Count, Columns.Count), , , xlByColumns, xlNext) Is Nothing Then
        lLeftCol = RangeFound(wks.Cells, , wks.Cells(Rows.Count, Columns.Count), , , xlByColumns, xlNext).Column
    Else
        Exit Sub
    End If
    
    lRightCol = RangeFound(wks.Cells, , wks.Cells(1, 1), , , xlByColumns).Column
    lTopRow = RangeFound(wks.Cells, , wks.Cells(Rows.Count, Columns.Count), , , , xlNext).Row
    lBotRow = RangeFound(wks.Cells).Row
    
    Set rngData = Range(wks.Cells(lTopRow, lLeftCol), wks.Cells(lBotRow, lRightCol))
    For Each rCell In rngData
        rCell.Value = Trim(rCell.Value)
    Next
    aryRaw = rngData.Value
    
    Set COL = New Collection
    
    With COL
        .Add Item:="dummy", Key:="DUMKEY"
        On Error Resume Next
        For x = LBound(aryRaw, 1) To UBound(aryRaw, 1)
            For y = LBound(aryRaw, 2) To UBound(aryRaw, 2)
                If Not aryRaw(x, y) = vbNullString Then
                    For i = 1 To .Count
                        If LCase(aryRaw(x, y)) < LCase(COL(i)) Then
                            .Add Item:=aryRaw(x, y), Key:=LCase(CStr(aryRaw(x, y))), Before:=i
                            Exit For
                        End If
                    Next
                    .Add Item:=aryRaw(x, y), Key:=LCase(CStr(aryRaw(x, y)))
                End If
            Next
        Next
        On Error GoTo 0
        .Remove "DUMKEY"
        
        ReDim aryData(1 To .Count, 1 To (((lRightCol - lLeftCol) + 1) * 2) + 2)
        
        For x = 1 To .Count
            
            lRunTot = 0
            
            For y = LBound(aryData, 2) To UBound(aryData, 2) Step 2
                aryData(x, y) = .Item(x)
            Next
            For y = LBound(aryData, 2) + 1 To UBound(aryData, 2) - 2 Step 2
                aryData(x, y) = Application.WorksheetFunction.CountIf(rngData.Columns(y / 2), .Item(x))
                lRunTot = lRunTot + aryData(x, y)
            Next
            aryData(x, UBound(aryData, 2)) = lRunTot
        Next
    End With
    
    With rngData(rngData.Rows.Count, 1).Offset(9, UBound(aryData, 2) - 1)
        .Value = "Total:"
        .Font.Bold = True
    End With
    rngData(rngData.Rows.Count, 1).Offset(10).Resize(UBound(aryData, 1), UBound(aryData, 2)).Value = aryData
End Sub
    
Function RangeFound(SearchRange As Range, _
                    Optional FindWhat As String = "*", _
                    Optional StartingAfter As Range, _
                    Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
                    Optional LookAtWholeOrPart As XlLookAt = xlPart, _
                    Optional SearchRowCol As XlSearchOrder = xlByRows, _
                    Optional SearchUpDn As XlSearchDirection = xlPrevious, _
                    Optional bMatchCase As Boolean = False) As Range
    
    If StartingAfter Is Nothing Then
        Set StartingAfter = SearchRange(1)
    End If
    
    Set RangeFound = SearchRange.Find(What:=FindWhat, _
                                      After:=StartingAfter, _
                                      LookIn:=LookAtTextOrFormula, _
                                      LookAt:=LookAtWholeOrPart, _
                                      SearchOrder:=SearchRowCol, _
                                      SearchDirection:=SearchUpDn, _
                                      MatchCase:=bMatchCase)
End Function

Hope that helps,

Mark

[sasa]

Dear Mark,
your work is perfect and allow me to spare a lot of work.
thank you so much

sasa

[GTO]

You bet sasa. Glad that worked and happy to help