VBA Express : Excel - Frequency Count of Selection

Excel

Frequency Count of Selection

Ease of Use

Intermediate

Version tested with

2000

Submitted by:

MWE

Description:

Count and display the frequency of each unique numeric value in a selection

Discussion:

Determining how often specific values in a range occur is a common need in many disciplines. This is not a true histogram, but, rather, a simple count of how many times numerical values are found. The procedure will determine the frequency count for all numerical values in a selection. The procedure was developed for integer/long type numbers. For counting purposes, numbers with a decimal portion are truncated to their integer portion using the Fix function. Note that Fix truncates independent of sign; thus Fix (1.4 ) = 1 and Fix ( -1.4 ) = -1 The results in this example are displayed via a MsgBox. Optional outputs include ?bad values? encountered and results written to the active worksheet.

Code:

instructions for use

			Option Explicit 
 
Sub xlFreqCount() 
     '
     '       Function    computes frequency count of unique values in a selection
     '
    Dim Count() As Integer 
    Dim I As Integer, J As Integer 
    Dim Num As Integer, NumOK As Integer, MaxNumOK As Integer, NumBad As Integer 
    Dim Row As Integer, Col As Integer, Temp1 As Integer, Temp2 As Integer 
    Dim strBuffer As String, strBadVals As String 
    Dim CellVal As Variant 
    Dim Ans As VbMsgBoxResult 
     
    Num = 0 
    NumBad = 0 
    NumOK = 0 
    MaxNumOK = 50 
    ReDim Count(MaxNumOK, 2) 
    strBuffer = "" 
     '
     '           sequence through each cell in selection
     '
    For Each Cell In Selection 
        Num = Num + 1 
        On Error Resume Next 
        CellVal = Cell.Value 
        Select Case Err 
        Case Is = 0 
             '
             '                   no error, examine type
             '
            Select Case LCase(TypeName(CellVal)) 
            Case "integer", "long", "single", "double" 
                 '
                 '                           numeric type; if single or double, use
                 '                           Fix function to reduce to integer portion
                 '
                If TypeName(CellVal) = "single" Or _ 
                TypeName(CellVal) = "double" Then 
                    CellVal = Fix(CellVal) 
                End If 
                 '
                 '                           check if previously seen
                 '                           if so, simply bump counter
                 '                           if not, increment NumOK and store value
                 '
                For I = 1 To NumOK 
                    If CellVal = Count(I, 1) Then 
                        Count(I, 2) = Count(I, 2) + 1 
                        Goto NextCell 
                    End If 
                Next I 
                NumOK = NumOK + 1 
                If NumOK > MaxNumOK Then 
                    MsgBox "capacity of freq count proc exceeded" & vbCrLf & _ 
                    "Displaying results so far", vbCritical 
                    Goto SortCount 
                End If 
                Count(NumOK, 1) = CellVal 
                Count(NumOK, 2) = 1 
            Case Else 
                NumBad = NumBad + 1 
                If Cell.Text <> "" Then 
                    strBadVals = strBadVals & Cell.Text & vbCrLf 
                Else 
                    strBadVals = strBadVals & "<blank>" & vbCrLf 
                End If 
            End Select 
        Case Is <> 0 
            NumBad = NumBad + 1 
            If Cell.Text <> "" Then 
                strBadVals = strBadVals & Cell.Text & vbCrLf 
            Else 
                strBadVals = strBadVals & "<blank>" & vbCrLf 
            End If 
        End Select 
NextCell: 
    Next Cell 
     '
     '           counting done, sort data
     '
SortCount: 
    For I = 1 To NumOK 
        For J = I To NumOK 
            If I <> J Then 
                If Count(I, 1) > Count(J, 1) Then 
                    Call SwapVals(Count(I, 1), Count(J, 1)) 
                    Call SwapVals(Count(I, 2), Count(J, 2)) 
                End If 
            End If 
        Next J 
    Next I 
     '
     '           store count data for display
     '
    For I = 1 To NumOK 
        strBuffer = strBuffer & Str(Count(I, 1)) & "   " + Str(Count(I, 2)) & vbCrLf 
    Next I 
     '
     '           display results
     '
    MsgBox "xlFreqCount" & vbCrLf & vbCrLf & _ 
    "# cells examined = " & Str(Num) & vbCrLf & _ 
    "# cells w/o acceptable numerical value = " & NumBad & vbCrLf & _ 
    "# unique values found = " & NumOK & vbCrLf & vbCrLf & _ 
    "Frequency Count:" & vbCrLf + strBuffer, vbInformation, "MWETools Utilities" 
    If NumBad > 0 Then 
        Ans = MsgBox("display non-numericas encountered?", vbQuestion & vbYesNo) 
        If Ans = vbYes Then MsgBox "Non Numerics encountered" & vbCrLf & strBadVals 
    End If 
     '
     '           write to worksheet?
     '
    Ans = MsgBox("Ok to write out results below selection?" & vbCrLf + _ 
    "results will be two cols by " & (NumOK + 1) & " rows", vbQuestion + vbYesNo) 
    If Ans <> vbYes Then Exit Sub 
    Row = Selection.Row + Selection.Rows.Count 
    Col = Selection.Column 
    Cells(Row, Col) = "Value" 
    Cells(Row, Col + 1) = "Count" 
    For I = 1 To NumOK 
        Cells(Row + I, Col) = Count(I, 1) 
        Cells(Row + I, Col + 1) = Count(I, 2) 
    Next I 
     
End Sub 
 
Sub SwapVals(X, Y) 
     '
     '       Function    swaps two values
     '
    Dim Temp 
     
    Temp = X 
    X = Y 
    Y = Temp 
     
End Sub

How to use:

Copy the above code.
Open a workbook.
Press Alt + F11 to open the Visual Basic Editor (VBE).
In the left side window, select the target spreadsheet [it will likely be called VBAProject(filename.xls) where filename is the name of the spreadsheet]
Select an existing code module for the target worksheet; or from the Insert Menu, choose Insert | Module.
Paste the code into the right-hand code window.
Close the VBE window, save the file if desired.

Test the code:

The example contains several selections to demonstrate how xlFreqCount reacts to various cell values
Open the example
Select one of the worksheet arrays (or create and select another group of numbers)
Click on the yellow box OR Go to Tools | Macro | Macros (or Alt+F8) and double-click on xlFreqCount
(N.B.: xlFreqCount is presently limited to finding 50 unique values for demonstration purposes. Reset the variable ?MaxNumOK? to a larger or smaller number as is appropriate for your needs.)

Sample File:

xlFreqCount.zip 18.98KB

Approved by mdmackillop

This entry has been viewed 146 times.