如何进行分类统计？

lion118

ykcbf1100 发表于 2024-7-17 20:07
你用他的代码就行了。忽略我的代码。

我看两个都很好，想学学，我尝试加入弹出对话框输入要统计名次，但是弹出对话框后，统计就出问题。Sub test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    ' 弹出对话框让用户输入名次段，以逗号分隔
    Dim inputMcd As String
    inputMcd = InputBox("请输入名次段，以逗号分隔", "输入名次段", "11000,19000")
   
    ' 将输入的名次段转换为数组
    Dim mcd As Variant
    mcd = Split(inputMcd, ",")
   
    ' 将名次段数组的元素转换为整数
    Dim i As Integer
    For i = LBound(mcd) To UBound(mcd)
        mcd(i) = CInt(mcd(i))
    Next i
   
    arr = Sheets("原始数据").[a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
   
    For j = 3 To UBound(arr, 2)
        If arr(1, j) <> "名次" Then
            d(arr(1, j)) = j
        End If
    Next
   
    For m = 0 To UBound(mcd)
        mc = mcd(m)
        For i = 2 To UBound(arr)
            bj = arr(i, 2)
            If Not d2.exists(bj) Then Set d2(bj) = CreateObject("scripting.dictionary")
            If Not d2(bj).exists(mc) Then Set d2(bj)(mc) = CreateObject("scripting.dictionary")
            For Each k In d.keys
                If arr(i, 4) <= mc Then
                    If arr(i, d(k) + 1) <= mc Then
                        d2(bj)(mc)(k) = d2(bj)(mc)(k) + 1
                    End If
                End If
            Next
        Next
    Next
   
    Set sh = Sheets("统计结果")
    sh.UsedRange = ""
    sh.UsedRange.UnMerge
    sh.[a1] = "班级"
    sh.[b1] = "名次段"
    sh.[c1].Resize(1, d.Count) = d.keys
   
    Dim hb As Range
    ksh = 2
    i = 2: j = 0
    For Each bj In d2.keys
        sh.Cells(i, 1) = bj
        For Each mc In d2(bj).keys
            sh.Cells(i, 2) = mc
            If hb Is Nothing Then
                Set hb = sh.Cells(i, 1)
            Else
                Set hb = Union(hb, sh.Cells(i, 1))
            End If
            For j = 3 To d.Count + 3
                sh.Cells(i, j) = d2(bj)(mc)(sh.Cells(1, j).Value)
            Next
            i = i + 1
        Next
        hb.Merge
        hb.HorizontalAlignment = xlCenter
        Set hb = Nothing
    Next
   
    sh.Range(sh.Cells(1, 1), sh.Cells(i - 1, d.Count + 2)).Borders.Weight = xlThin
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "OK!"
End Sub

kyxfyzg

lion118 发表于 2024-7-17 17:02
您好，您这个代码运行不了。谢谢。

不好意思，忘了字典还是前期引用，这回应该没问题了
Sub test()
Set d = CreateObject ("scripting.dictionary")
Set dd = CreateObject ("scripting.dictionary")
With Sheets("原始数据")
arr = .UsedRange
For i = 3 To UBound(arr, 2)
    If arr(1, i) <> "名次" Then
        d(arr(1, i)) = i + 1
    End If
Next i
ls = d.Items
For i = 2 To UBound(arr)
    dd(arr(i, 2)) = ""
Next i
bj = dd.Keys
For j = 0 To UBound(ls)
    For i = 0 To UBound(bj)
        n = WorksheetFunction.CountIfs(.Columns(2), bj(i), .Columns(ls(j)), "<11000")
        m = WorksheetFunction.CountIfs(.Columns(2), bj(i), .Columns(ls(j)), "<19000")
        If n <> 0 Then Sheets("统计结果").Cells(2 + 2 * i, 3 + j) = n
        If m <> 0 Then Sheets("统计结果").Cells(3 + 2 * i, 3 + j) = m
    Next i
Next j
End With
End Sub