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
01-27-2010, 02:32 AM
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
Bob Phillips
01-27-2010, 11:44 AM
[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 © 2024 vBulletin Solutions Inc. All rights reserved.