メモ書きです。
Option Explicit

Public Sub 出力_中項目別_小項目数()
    Dim wsSrc As Worksheet, wsOut As Worksheet
    Dim lastRow As Long, r As Long
    Dim s As String, parts() As String
    Dim a As String, b As String, c As String, d As String, key As String
    Dim mapABC As Object, setD As Object
    Dim keys As Variant, i As Long, outRow As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set wsSrc = ActiveSheet
    
    ' 出力シートを再作成
    On Error Resume Next
    Application.DisplayAlerts = False
    ThisWorkbook.Worksheets("中項目別_小項目数").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Set wsOut = ThisWorkbook.Worksheets.Add
    wsOut.Name = "中項目別_小項目数"
    
    Set mapABC = CreateObject("Scripting.Dictionary")
    
    lastRow = wsSrc.Cells(wsSrc.Rows.Count, "Q").End(xlUp).Row
    For r = 1 To lastRow
        s = Trim$(CStr(wsSrc.Cells(r, "Q").Value))
        If Len(s) = 0 Then GoTo ContinueRow
        
        ' 末尾のドット削除
        Do While Right$(s, 1) = "."
            s = Left$(s, Len(s) - 1)
        Loop
        
        ' 分割
        parts = Split(s, ".")
        
        ' ★要素数が4つ未満はスキップ（例：1. や 1.1.）
        If UBound(parts) < 3 Then GoTo ContinueRow
        
        a = Trim$(parts(0))
        b = Trim$(parts(1))
        c = Trim$(parts(2))
        d = Trim$(parts(3))
        If a = "" Or b = "" Or c = "" Or d = "" Then GoTo ContinueRow
        
        key = a & "." & b & "." & c
        
        If Not mapABC.Exists(key) Then
            Set setD = CreateObject("Scripting.Dictionary")
            mapABC.Add key, setD
        Else
            Set setD = mapABC(key)
        End If
        If Not setD.Exists(d) Then setD.Add d, True
        
ContinueRow:
    Next r
    
    ' 出力
    With wsOut
        .Range("A1:D1").Value = Array("大項目", "第2値", "中項目", "小項目数")
    End With
    
    keys = mapABC.Keys
    outRow = 2
    For i = LBound(keys) To UBound(keys)
        parts = Split(keys(i), ".")
        wsOut.Cells(outRow, 1).Value = parts(0)
        wsOut.Cells(outRow, 2).Value = parts(1)
        wsOut.Cells(outRow, 3).Value = parts(2)
        wsOut.Cells(outRow, 4).Value = mapABC(keys(i)).Count
        outRow = outRow + 1
    Next i
    
    ' 並び替えと調整
    If outRow > 2 Then
        wsOut.Range("A1:D" & outRow - 1).Sort Key1:=wsOut.Range("A2"), Order1:=xlAscending, _
                                              Key2:=wsOut.Range("B2"), Order2:=xlAscending, _
                                              Key3:=wsOut.Range("C2"), Order3:=xlAscending, _
                                              Header:=xlYes
        wsOut.Columns("A:D").AutoFit
    End If
    
    MsgBox "出力完了：短い形式（1. や 1.1.）は除外しました。", vbInformation
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub