Create a Frequency Analysis Table from Amounts using Excel VBA

Have you ever needed to understand how your data is distributed — like how many amounts fall in a particular range? This macro will help you group your amount values into intervals and create a stratified frequency table in a new worksheet.

What is the Output of this VBA?

Here is an example video of what this VBA Code can do!

What This Macro Does

• Asks the user to select a column of numeric data (e.g., “Amounts”)
• Automatically calculates:
  • Average, Min, Max
  • Number of intervals
• Creates a new sheet called Frequency Analysis
• Shows interval distribution with:
  • Count
  • Percentage
• Adds a second table with only non-zero intervals
• Also tags each row in the original sheet with the interval it belongs to

What is benefit of using this VBA?

VBA Code

Sub Stratified_Table()
    ' Declare variables
    Dim ws As Worksheet
    Dim newWs As Worksheet
    Dim dataRange As Range
    Dim lastRow As Long
    Dim lastCol As Long
    Dim amountCol As Long
    Dim totalSum As Double
    Dim avgAmount As Double
    Dim minAmount As Double
    Dim maxAmount As Double
    Dim intervalSize As Double
    Dim numIntervals As Integer
    Dim i As Integer
    Dim cell As Range
    Dim intervalCounts() As Long
    Dim lowerBound As Double
    Dim upperBound As Double

    ' Set reference to active worksheet
    Set ws = ActiveSheet

    ' Find the last used row and column in the data
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

    ' Ask user to select the column containing amount values
    On Error Resume Next
    Set dataRange = Application.InputBox("Please select the range containing the amount values", "Select Data", Type:=8)
    On Error GoTo 0

    ' Exit if user cancels
    If dataRange Is Nothing Then
        MsgBox "Operation cancelled by user.", vbExclamation
        Exit Sub
    End If

    ' Calculate statistics on the amount values
    totalSum = 0
    minAmount = CDbl(dataRange.Cells(1))
    maxAmount = CDbl(dataRange.Cells(1))

    ' Sum all values and find min/max
    For Each cell In dataRange
        If IsNumeric(cell.Value) Then
            totalSum = totalSum + CDbl(cell.Value)

            If CDbl(cell.Value) < minAmount Then minAmount = CDbl(cell.Value)
            If CDbl(cell.Value) > maxAmount Then maxAmount = CDbl(cell.Value)
        End If
    Next cell

    ' Calculate average
    avgAmount = totalSum / dataRange.Count

    ' Calculate number of intervals based on min, max and average
    numIntervals = Application.WorksheetFunction.RoundUp((maxAmount - minAmount) / avgAmount, 0) + 1

    ' Set interval size
    intervalSize = avgAmount

    ' Create new worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    ActiveWorkbook.Sheets("Frequency Analysis").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

    Set newWs = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))
    newWs.Name = "Frequency Analysis"

    ' Setup headers
    newWs.Cells(1, 1) = "Interval"
    newWs.Cells(1, 2) = "Lower Bound"
    newWs.Cells(1, 3) = "Upper Bound"
    newWs.Cells(1, 4) = "Count"
    newWs.Cells(1, 5) = "Percentage"

    With newWs.Range("A1:E1")
        .Font.Bold = True
        .Interior.Color = RGB(200, 200, 200)
    End With

    ReDim intervalCounts(1 To numIntervals)

    Dim startPoint As Double
    startPoint = minAmount - (minAmount Mod intervalSize)
    If startPoint > minAmount Then startPoint = startPoint - intervalSize

    ' Count frequency
    For Each cell In dataRange
        If IsNumeric(cell.Value) Then
            For i = 1 To numIntervals
                lowerBound = startPoint + (i - 1) * intervalSize
                upperBound = startPoint + i * intervalSize

                If i < numIntervals Then
                    If cell.Value >= lowerBound And cell.Value < upperBound Then
                        intervalCounts(i) = intervalCounts(i) + 1
                        Exit For
                    End If
                Else
                    If cell.Value >= lowerBound And cell.Value <= upperBound Then
                        intervalCounts(i) = intervalCounts(i) + 1
                        Exit For
                    End If
                End If
            Next i
        End If
    Next cell

    ' Fill main table
    For i = 1 To numIntervals
        lowerBound = startPoint + (i - 1) * intervalSize
        upperBound = startPoint + i * intervalSize

        newWs.Cells(i + 1, 1) = i
        newWs.Cells(i + 1, 2) = lowerBound
        newWs.Cells(i + 1, 3) = upperBound
        newWs.Cells(i + 1, 4) = intervalCounts(i)
        newWs.Cells(i + 1, 5) = FormatPercent(intervalCounts(i) / dataRange.Count)
    Next i

    newWs.Range("B2:C" & numIntervals + 1).NumberFormat = "$#,##0.00"

    ' Summary Stats
    newWs.Cells(numIntervals + 3, 1) = "Summary Statistics"
    newWs.Cells(numIntervals + 3, 1).Font.Bold = True
    newWs.Cells(numIntervals + 4, 1) = "Average Amount:"
    newWs.Cells(numIntervals + 4, 2) = avgAmount
    newWs.Cells(numIntervals + 5, 1) = "Minimum Amount:"
    newWs.Cells(numIntervals + 5, 2) = minAmount
    newWs.Cells(numIntervals + 6, 1) = "Maximum Amount:"
    newWs.Cells(numIntervals + 6, 2) = maxAmount
    newWs.Cells(numIntervals + 7, 1) = "Total Count:"
    newWs.Cells(numIntervals + 7, 2) = dataRange.Count

    newWs.Range("B" & numIntervals + 4 & ":B" & numIntervals + 6).NumberFormat = "$#,##0.00"

    ' Non-zero Interval Table
    Dim nonZeroRow As Integer: nonZeroRow = 3
    newWs.Range("G1:K1").Merge
    newWs.Cells(1, 7) = "Non-Zero Intervals"
    newWs.Cells(2, 7) = "Interval"
    newWs.Cells(2, 8) = "Lower Bound"
    newWs.Cells(2, 9) = "Upper Bound"
    newWs.Cells(2, 10) = "Count"
    newWs.Cells(2, 11) = "Percentage"

    With newWs.Range("G2:K2")
        .Font.Bold = True
        .Interior.Color = RGB(220, 220, 220)
    End With

    For i = 1 To numIntervals
        If intervalCounts(i) > 0 Then
            lowerBound = startPoint + (i - 1) * intervalSize
            upperBound = startPoint + i * intervalSize

            newWs.Cells(nonZeroRow, 7) = i
            newWs.Cells(nonZeroRow, 8) = lowerBound
            newWs.Cells(nonZeroRow, 9) = upperBound
            newWs.Cells(nonZeroRow, 10) = intervalCounts(i)
            newWs.Cells(nonZeroRow, 11) = FormatPercent(intervalCounts(i) / dataRange.Count)

            nonZeroRow = nonZeroRow + 1
        End If
    Next i

    newWs.Range("H3:I" & nonZeroRow - 1).NumberFormat = "$#,##0.00"

    ' Map each row in original sheet to interval
    Dim rowIndex As Long, intervalFound As Boolean
    amountCol = dataRange.Column
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    ws.Cells(1, lastCol + 1) = "Interval"

    For rowIndex = dataRange.Row To dataRange.Row + dataRange.Rows.Count - 1
        If IsNumeric(ws.Cells(rowIndex, amountCol).Value) Then
            intervalFound = False
            For i = 1 To numIntervals
                lowerBound = startPoint + (i - 1) * intervalSize
                upperBound = startPoint + i * intervalSize

                If i < numIntervals Then
                    If ws.Cells(rowIndex, amountCol).Value >= lowerBound And ws.Cells(rowIndex, amountCol).Value < upperBound Then
                        ws.Cells(rowIndex, lastCol + 1).Value = i
                        intervalFound = True
                        Exit For
                    End If
                Else
                    If ws.Cells(rowIndex, amountCol).Value >= lowerBound And ws.Cells(rowIndex, amountCol).Value <= upperBound Then
                        ws.Cells(rowIndex, lastCol + 1).Value = i
                        intervalFound = True
                        Exit For
                    End If
                End If
            Next i
            If Not intervalFound Then ws.Cells(rowIndex, lastCol + 1).Value = "Out of Range"
        End If
    Next rowIndex

    ' Auto fit
    newWs.Columns("A:E").AutoFit
    newWs.Columns("G:K").AutoFit
    ws.Columns(lastCol + 1).AutoFit

    newWs.Activate
    MsgBox "Frequency analysis complete!", vbInformation
End Sub

Usage Instructions

1. Open Excel and press Alt + F11 to open the VBA Editor.
2. Insert a new module (Insert > Module).
3. Copy and paste the above VBA code.
4. Create a sheet with a list of transactions.
5. Run Stratified_Table macro.