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]

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

[Bob Phillips]

[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

[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:thumb