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

Don't you just want something like

=COUNTIF(B:B,"Mazzoni")

yes...thanks..

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

lucas

01-27-2010, 10:27 AM

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]

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

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

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

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

in the attached file there is what I need

sasa

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

Dear Mark,

your work is perfect and allow me to spare a lot of work.

thank you so much

sasa

You bet sasa. Glad that worked and happy to help:thumb

Powered by vBulletin® Version 4.2.5 Copyright © 2019 vBulletin Solutions Inc. All rights reserved.