Option Explicit
Sub xlFreqCount()
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 = ""
For Each Cell In Selection
Num = Num + 1
On Error Resume Next
CellVal = Cell.Value
Select Case Err
Case Is = 0
Select Case LCase(TypeName(CellVal))
Case "integer", "long", "single", "double"
If TypeName(CellVal) = "single" Or _
TypeName(CellVal) = "double" Then
CellVal = Fix(CellVal)
End If
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
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
For I = 1 To NumOK
strBuffer = strBuffer & Str(Count(I, 1)) & " " + Str(Count(I, 2)) & vbCrLf
Next I
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
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)
Dim Temp
Temp = X
X = Y
Y = Temp
End Sub
|