Need help creating a count macro

[euroride7]

Can somebody please tell me how to write the VBA code for this. Thank
you.

The following is a security log indicating a bunch of differents
events that occured (sample data). The actual list is much longer. I
have 4 workseets corresponding to 4 different computer logs.

Event ID Category
529 Logon/Logoff
537 Logon/Logoff
681 Account Logon
565 Directory Service Access
627 Account Management
677 Account Logon

I need to create a macro that counts how many times each Event ID
occured and put it in a new column "Instances" to look like below.
Please help.

Event ID Category Instances
529 Logon/Logoff 4
537 Logon/Logoff 78
539 Logon/Logoff 17
565 Directory Service Access 590
577 Privilege Use 1
627 Account Management 1
675 Account Logon 1852
676 Account Logon 90
677 Account Logon 121
681 Account Logon 41

 

[RB Smissaert]

This is a very fast and flexible function I use for this purpose.
It needs a reference to Olaf Schmidt's free dll, dhRichClient, which can be
downloaded from here:
www.datenhaus.de/Downloads/dhRichClientDemo.zip

Public Function MakeFrequencyArray(arrVariant As Variant, _
Optional lCols As Long = -1, _
Optional bSortDescOnCount As Boolean =
True, _
Optional bSortAscOnCount As Boolean, _
Optional bSortDescOnItem As Boolean, _
Optional bSortAscOnItem As Boolean, _
Optional strFormat As String) As Variant

Dim i As Long
Dim c As Long
Dim LB As Long
Dim UB As Long
Dim LB2 As Long
Dim UB2 As Long
Dim cSD1 As cSortedDictionary
Dim cSD2 As cSortedDictionary
Dim lCount As Long
Dim lcSD1Count As Long
Dim lcSD2Count As Long
Dim arrReturn

LB = LBound(arrVariant)
UB = UBound(arrVariant)

Set cSD1 = New cSortedDictionary

If lCols = -1 Then
For i = LB To UB
If cSD1.Exists(arrVariant(i)) Then
lCount = cSD1.Item(arrVariant(i))
lCount = lCount + 1
cSD1.Item(arrVariant(i)) = lCount
Else
cSD1.Add arrVariant(i), 1
End If
Next i
Else
LB2 = LBound(arrVariant, 2)
UB2 = UBound(arrVariant, 2)
If lCols = 1 Then 'to gain some speed?
For i = LB To UB
If cSD1.Exists(arrVariant(i, LB2)) Then
lCount = cSD1.Item(arrVariant(i, LB2))
lCount = lCount + 1
cSD1.Item(arrVariant(i, LB2)) = lCount
Else
cSD1.Add arrVariant(i, LB2), 1
End If
Next i
Else
For i = LB To UB
For c = LB2 To UB2
If cSD1.Exists(arrVariant(i, c)) Then
lCount = cSD1.Item(arrVariant(i, c))
lCount = lCount + 1
cSD1.Item(arrVariant(i, c)) = lCount
Else
cSD1.Add arrVariant(i, c), 1
End If
Next c
Next i
End If
End If

If bSortDescOnCount Or bSortAscOnCount Then

Set cSD2 = New cSortedDictionary
cSD2.UniqueKeys = False

For i = 1 To cSD1.Count
cSD2.Add cSD1.ItemByIndex(i - 1), cSD1.KeyByIndex(i - 1)
Next i

lcSD2Count = cSD2.Count

'return a 1-based 2-D variant array
'----------------------------------
ReDim arrReturn(1 To lcSD2Count, 1 To 4)

If Len(strFormat) > 0 Then
If bSortDescOnCount Then
For i = 0 To lcSD2Count - 1
arrReturn(lcSD2Count - i, 1) = lcSD2Count - i
arrReturn(lcSD2Count - i, 2) = Format(cSD2.ItemByIndex(i),
strFormat)
'for some reason this is needed to avoid a currency sign in front
of the number
'------------------------------------------------------------------------------
arrReturn(lcSD2Count - i, 3) = CLng(cSD2.KeyByIndex(i))
arrReturn(lcSD2Count - i, 4) = _
Format(arrReturn(lcSD2Count - i, 3) / (UB + (1 - LB)), "0.00%")
Next i
Else
For i = 0 To lcSD2Count - 1
arrReturn(i + 1, 1) = i + 1
arrReturn(i + 1, 2) = Format(cSD2.ItemByIndex(i), strFormat)
arrReturn(i + 1, 3) = CLng(cSD2.KeyByIndex(i))
arrReturn(i + 1, 4) = _
Format(arrReturn(i + 1, 3) / (UB + (1 - LB)), "0.00%")
Next i
End If
Else
If bSortDescOnCount Then
For i = 0 To lcSD2Count - 1
arrReturn(lcSD2Count - i, 1) = lcSD2Count - i
arrReturn(lcSD2Count - i, 2) = cSD2.ItemByIndex(i)
arrReturn(lcSD2Count - i, 3) = CLng(cSD2.KeyByIndex(i))
arrReturn(lcSD2Count - i, 4) = _
Format(arrReturn(lcSD2Count - i, 3) / (UB + (1 - LB)), "0.00%")
Next i
Else
For i = 0 To lcSD2Count - 1
arrReturn(i + 1, 1) = i + 1
arrReturn(i + 1, 2) = cSD2.ItemByIndex(i)
arrReturn(i + 1, 3) = CLng(cSD2.KeyByIndex(i))
arrReturn(i + 1, 4) = _
Format(arrReturn(i + 1, 3) / (UB + (1 - LB)), "0.00%")
Next i
End If
End If

Else 'If bSortDescOnCount Or bSortAscOnCount

lcSD1Count = cSD1.Count

'return a 1-based 2-D variant array
'----------------------------------
ReDim arrReturn(1 To lcSD1Count, 1 To 4)

If Len(strFormat) > 0 Then
If bSortDescOnItem Then
For i = 0 To lcSD1Count - 1
arrReturn(lcSD1Count - i, 1) = lcSD1Count - i
arrReturn(lcSD1Count - i, 2) = Format(cSD1.KeyByIndex(i),
strFormat)
arrReturn(lcSD1Count - i, 3) = CLng(cSD1.ItemByIndex(i))
arrReturn(lcSD2Count - i, 4) = _
Format(arrReturn(lcSD1Count - i, 3) / (UB + (1 - LB)), "0.00%")
Next i
Else
For i = 0 To lcSD1Count - 1
arrReturn(i + 1, 1) = i + 1
arrReturn(i + 1, 2) = Format(cSD1.KeyByIndex(i), strFormat)
arrReturn(i + 1, 3) = CLng(cSD1.ItemByIndex(i))
arrReturn(i + 1, 4) = _
Format(arrReturn(i + 1, 3) / (UB + (1 - LB)), "0.00%")
Next i
End If
Else
If bSortDescOnItem Then
For i = 0 To lcSD1Count - 1
arrReturn(lcSD1Count - i, 1) = lcSD1Count - i
arrReturn(lcSD1Count - i, 2) = cSD1.KeyByIndex(i)
arrReturn(lcSD1Count - i, 3) = CLng(cSD1.ItemByIndex(i))
arrReturn(lcSD2Count - i, 4) = _
Format(arrReturn(lcSD1Count - i, 3) / (UB + (1 - LB)), "0.00%")
Next i
Else
For i = 0 To lcSD1Count - 1
arrReturn(i + 1, 1) = i + 1
arrReturn(i + 1, 2) = cSD1.KeyByIndex(i)
arrReturn(i + 1, 3) = CLng(cSD1.ItemByIndex(i))
arrReturn(i + 1, 4) = _
Format(arrReturn(i + 1, 3) / (UB + (1 - LB)), "0.00%")
Next i
End If
End If

End If 'If bSortDescOnCount Or bSortAscOnCount

MakeFrequencyArray = arrReturn

End Function

So, you pass the function an array and a number of optional arguments and it
will return
your counted items (and the frequency as well) as an array.
To make an array from a range simply do something like this:

Dim arr

arr = Range(Cells(1), Cells(1000, 1))


There are simpler ways to do the same, but all the thinking has already been
done, plus it
has been fully tested. Really fast as well and that could be important if
you are dealing with
large ranges.


RBS

 

[dbKemp]

Can somebody please tell me how to write the VBA code for this. Thank
you.

The following is a security log indicating a bunch of differents
events that occured (sample data). The actual list is much longer.  I
have 4 workseets corresponding to 4 different computer logs.

Event ID        Category
529     Logon/Logoff
537     Logon/Logoff
681     Account Logon
565     Directory Service Access
627     Account Management
677     Account Logon

I need to create a macro that counts how many times each Event ID
occured and put it in a new column "Instances" to look like below.
Please help.

Event ID        Category                                  Instances
529     Logon/Logoff                      4
537     Logon/Logoff                     78
539     Logon/Logoff                     17
565     Directory Service Access        590
577     Privilege Use                    1
627     Account Management       1
675     Account Logon                  1852
676     Account Logon                  90
677     Account Logon                  121
681     Account Logon                  41

This is code I provided for another current post (Count Uniques in
Column G Until Change in Column C, then Restart C), but it gives you
the basic idea....

Try this:

Private Sub Test()
'Scripting.Dictionaries require reference to MS Scripting Runtime
Dim dicNames As Scripting.Dictionary
Dim dicIDs As Scripting.Dictionary
'Input ranges
Dim rNames As Excel.Range
Dim rIDs As Excel.Range
'Counter
Dim lCtr As Long
'Value in Name column
Dim sName As String
'Value in ID Column
Dim vID As Variant

'These will be different for you
Set rNames = Sheets(1).Range("A1:A8")
Set rIDs = Sheets(1).Range("B1:B8")

'Initialize Name dictionary
Set dicNames = New Scripting.Dictionary
'Loop through cells in ranges (This can be done quicker if
necessary)
For lCtr = 1 To rNames.Rows.Count
'Get name and ID
sName = rNames(lCtr, 1).Value
vID = rIDs(lCtr, 1).Value

'See if name exists in Name dictionary
If dicNames.Exists(sName) Then
'If yes set IDs dictionary = to it's value
Set dicIDs = dicNames(sName)
Else
'If not, create a new dictionary
Set dicIDs = New Scripting.Dictionary
End If
'Add ID to IDs dictionary
'Doing it like this instead of using .Add will eliminate Dupe
IDs for same name
dicIDs(vID) = vID
'Store dicIDs in dicNames
Set dicNames(sName) = dicIDs
Next

'Get count of ID's for each Name
For lCtr = 0 To dicNames.Count - 1
Set dicIDs = dicNames.Items(lCtr)
'This will be different for you
MsgBox "Name: " & dicNames.Keys(lCtr) & " , Count: " &
dicIDs.Count
Next
End Sub

 

[FSt1]

hi
not to discourage you but a countif formula might do you just as well
=countif(A1:A1000,529)
you would need a countif formula for each envent id.

Regards
FSt1