All,
I've written a macro that does a rudimentary Benford analysis (the first digit comparison only), but after looking at the code I produced, I can't help but think there must be a better way to do it. I'm a beginner coder, at best. I'll paste the code below, and I'd love to hear if anyone has any advice on making this more efficient.
Thanks much!
P.S. Cross-posted at technet forums here: http://social.technet.microsoft.com...e8d-4560-98d2-3cb000e5e4c5/benford-macro-help
I've written a macro that does a rudimentary Benford analysis (the first digit comparison only), but after looking at the code I produced, I can't help but think there must be a better way to do it. I'm a beginner coder, at best. I'll paste the code below, and I'd love to hear if anyone has any advice on making this more efficient.
Thanks much!
Code:
Sub benford()
Dim i, j, k, l, m, n, counter, cell_length As Long
Dim numbers_to_analyze(1 To 1000000) As Long
Dim first_position_numbers(1 To 1000000) As Long
Dim count(1 To 10) As Long
Dim first_position_count(1 To 10) As Long
Dim num_rows, num_columns As Long
Dim myRange, headerRange, percentagesRange As Range
On Error GoTo ErrorCatch
Set myRange = Selection
num_rows = myRange.Rows.count
num_columns = myRange.Columns.count
counter = 0
For n = myRange.Row To (myRange.Row + num_rows - 1)
ActiveSheet.Cells(n, myRange.Column) = Abs(ActiveSheet.Cells(n, myRange.Column))
Next n
For i = myRange.Row To (myRange.Row + num_rows - 1)
For j = myRange.Column To (myRange.Column + num_columns - 1)
cell_length = Len(ActiveSheet.Cells(i, j).Value)
For k = 1 To cell_length
If IsNumeric(Mid(ActiveSheet.Cells(i, j).Value, k, 1)) Then
numbers_to_analyze(counter + 1) = CInt(Mid(ActiveSheet.Cells(i, j).Value, k, 1))
Else: counter = counter - 1
End If
If k = 1 And IsNumeric(Mid(ActiveSheet.Cells(i, j).Value, k, 1)) Then
If numbers_to_analyze(counter + 1) = 1 Then
first_position_count(1) = first_position_count(1) + 1
ElseIf numbers_to_analyze(counter + 1) = 2 Then
first_position_count(2) = first_position_count(2) + 1
ElseIf numbers_to_analyze(counter + 1) = 3 Then
first_position_count(3) = first_position_count(3) + 1
ElseIf numbers_to_analyze(counter + 1) = 4 Then
first_position_count(4) = first_position_count(4) + 1
ElseIf numbers_to_analyze(counter + 1) = 5 Then
first_position_count(5) = first_position_count(5) + 1
ElseIf numbers_to_analyze(counter + 1) = 6 Then
first_position_count(6) = first_position_count(6) + 1
ElseIf numbers_to_analyze(counter + 1) = 7 Then
first_position_count(7) = first_position_count(7) + 1
ElseIf numbers_to_analyze(counter + 1) = 8 Then
first_position_count(8) = first_position_count(8) + 1
ElseIf numbers_to_analyze(counter + 1) = 9 Then
first_position_count(9) = first_position_count(9) + 1
ElseIf numbers_to_analyze(counter + 1) = 0 Then
first_position_count(10) = first_position_count(10) + 1
End If
End If
counter = counter + 1
Next k
Next j
Next i
For l = 1 To counter
If numbers_to_analyze(l) = 1 Then
count(1) = count(1) + 1
ElseIf numbers_to_analyze(l) = 2 Then
count(2) = count(2) + 1
ElseIf numbers_to_analyze(l) = 3 Then
count(3) = count(3) + 1
ElseIf numbers_to_analyze(l) = 4 Then
count(4) = count(4) + 1
ElseIf numbers_to_analyze(l) = 5 Then
count(5) = count(5) + 1
ElseIf numbers_to_analyze(l) = 6 Then
count(6) = count(6) + 1
ElseIf numbers_to_analyze(l) = 7 Then
count(7) = count(7) + 1
ElseIf numbers_to_analyze(l) = 8 Then
count(8) = count(8) + 1
ElseIf numbers_to_analyze(l) = 9 Then
count(9) = count(9) + 1
ElseIf numbers_to_analyze(l) = 0 Then
count(10) = count(10) + 1
End If
Next l
Sheets.Add.Name = "Benford"
Sheets("Benford").Cells(1, 1).Value = "Value"
Sheets("Benford").Cells(1, 2).Value = "Frequency"
Sheets("Benford").Cells(1, 3).Value = "Frequency in 1st Position"
Sheets("Benford").Cells(1, 4).Value = "%age FP Frequency"
Sheets("Benford").Cells(1, 5).Value = "Benford FP Expectation"
Sheets("Benford").Cells(1, 5).EntireColumn.ColumnWidth = Sheets("Benford").Cells(1, 5).EntireColumn.ColumnWidth + 1.5
Set headerRange = Sheets("Benford").Range("A1", "E1")
With headerRange.Font
.Name = "Arial"
.Size = 8
.Bold = True
End With
With headerRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
End With
Sheets("Benford").Cells(2, 1).Value = "Ones"
Sheets("Benford").Cells(3, 1).Value = "Twos"
Sheets("Benford").Cells(4, 1).Value = "Threes"
Sheets("Benford").Cells(5, 1).Value = "Fours"
Sheets("Benford").Cells(6, 1).Value = "Fives"
Sheets("Benford").Cells(7, 1).Value = "Sixes"
Sheets("Benford").Cells(8, 1).Value = "Sevens"
Sheets("Benford").Cells(9, 1).Value = "Eights"
Sheets("Benford").Cells(10, 1).Value = "Nines"
Sheets("Benford").Cells(11, 1).Value = "Zeroes"
For m = 1 To 10
Sheets("Benford").Cells(m + 1, 2).Value = count(m)
Sheets("Benford").Cells(m + 1, 3).Value = first_position_count(m)
If m >= 1 And m < 10 Then Sheets("Benford").Cells(m + 1, 4).Formula = "=C" & (m + 1) & "/SUM($C$2:$C$10)"
If m >= 1 And m < 10 Then Sheets("Benford").Cells(m + 1, 5).Value = (Log(1 + (1 / m))) / Log(10)
Next m
Set percentagesRange = Sheets("Benford").Range("D2", "E10")
percentagesRange.NumberFormat = "0.0%;(0.0%)"
percentagesRange.Select
Charts.Add
ActiveChart.ChartType = xlLine
ActiveChart.SetSourceData Source:=percentagesRange
ActiveChart.Location Where:=xlLocationAsObject, Name:="Benford"
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "Benford v. Actual"
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Digit"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Percentage"
.SeriesCollection(1).Name = "=""Actual"""
.SeriesCollection(2).Name = "=""Benford"""
End With
Sheets("Benford").Range("A1").Select
ErrorCatch:
'MsgBox Err.Description
End Sub
P.S. Cross-posted at technet forums here: http://social.technet.microsoft.com...e8d-4560-98d2-3cb000e5e4c5/benford-macro-help
Last edited: