[已解决]VBA函数来进行数字归类，为什么运算没有结果。

yearabc

我想把区域内数字按一定规律归类，VBA函数设计好了，也看见在运算，怎么就没有结果呢？


Sub aa()
    Set d = CreateObject("Scripting.Dictionary")
    ar = [N3:S6]: ReDim br(9)
    For j = 1 To UBound(ar, 2)
        For i = 1 To UBound(ar)
            For x = 0 To 9
                If InStr(ar(i, j), x) Then d(x) = d(x) + 1
            Next
        Next
        On Error Resume Next
        For y = 0 To 9
            br(y) = IIf(d(y) > br(y), d(y), br(y))
        Next
        d.RemoveAll
    Next
    For i = 11 To 14
        For x = 0 To 9
            If br(x) = Cells(i, 14) Then s = s & x
        Next
        Cells(i, 15) = s: s = ""
    Next
    Call zz
End Sub


Sub zz()
    Set d = CreateObject("Scripting.Dictionary")
    ar = [N7:S10]: ReDim br(9)
    For j = 1 To UBound(ar, 2)
        For i = 1 To UBound(ar)
            For x = 0 To 9
                If InStr(ar(i, j), x) Then d(x) = d(x) + 1
            Next
        Next
        On Error Resume Next
        For y = 0 To 9
            br(y) = IIf(d(y) > br(y), d(y), br(y))
        Next
        d.RemoveAll
    Next
    For i = 11 To 14
        For x = 0 To 9
            If br(x) = Cells(i, 14) Then s = s & x
        Next
        Cells(i, 18) = s: s = ""
    Next

End Sub

宏aa目的是                N3:S6中的数字在每行出现1次的归类在O11，出现2次的放在O12,出现3次的放在O13,出现4次的放在O14
宏zz目的是                N7:S10中的数字在每行出现1次的归类在R11，出现2次的放在R12,出现3次的放在R13,出现4次的放在R14

最佳答案

月排行榜 / 总排行榜

hasyh2008

2022-6-8 23:14

Sub 统计()
    Dim Arr(), Brr, Crr(1 To 4, 1 To 1), X%, Y%, K%
    Dim Str$
    Dim D
    Set D = CreateObject("scripting.dictionary")
    With Sheet1
        Arr = .Range("N3:S6")
        For X = 1 To UBound(Arr)
            For Y = 1 To UBound(Arr, 2)
                For K = 0 To 9
                    If InStr(Arr(X, Y), K) Then D(K) = D(K) + 1
                Next K
            Next Y
        Next X
        Arr = Application.Transpose(Array(D.keys, D.items))
        For X = 1 To UBound(Arr)
            Select Case Arr(X, 2)
                Case Is = 1
                    Crr(1, 1) = Crr(1, 1) & Arr(X, 1) & ","
                Case Is = 2
                    Crr(2, 1) = Crr(2, 1) & Arr(X, 1) & ","
                Case Is = 3
                    Crr(3, 1) = Crr(3, 1) & Arr(X, 1) & ","
                Case Is = 4
                    Crr(4, 1) = Crr(4, 1) & Arr(X, 1) & ","
            End Select
        Next X
        .Range("O11").Resize(4, 1) = ""
        .Range("O11").Resize(4, 1) = Crr
    End With
End Sub

跳转到最佳答案楼层

eennoo

1. 
   
2. Sub aa()
   
3. ReDim br(9)
   
4. For Each Rng In [N3:S6]
   
5. 
   
6.     For n = 0 To 9
   
7.         If InStr(Rng, n) > 0 Then
   
8.         br(n) = br(n) + (Len(Rng) - Len(Replace(Rng, n, "")))
   
9.         End If
   
10.     Next
    
11. 
    
12. Next
    
13. 
    
14.     For i = 11 To 14
    
15.         For x = 0 To 9
    
16.             If Cells(i, "n") = CStr(br(x)) Then
    
17.                 s = s & x
    
18.             End If
    
19.         Next
    
20.         Cells(i, 15) = s: s = ""
    
21.         s = ""
    
22.         
    
23.         Next
    
24. End Sub
    
25. 
    

复制代码

yearabc

eennoo 发表于 2022-6-2 00:56

谢谢，结果不是我需要的。所有分类都在O14里面了。

yearabc

我案例表格中的函数和公式复制在另外的电子表格中，是可以运行的，不知道原因。
我的表达有些不清楚，应该是统计每一列中数字的出现次数，取最大次数放在O和R中标注的次数中。

hasyh2008

Sub 统计()
    Dim Arr(), Brr, Crr(1 To 4, 1 To 1), X%, Y%, K%
    Dim Str$
    Dim D
    Set D = CreateObject("scripting.dictionary")
    With Sheet1
        Arr = .Range("N3:S6")
        For X = 1 To UBound(Arr)
            For Y = 1 To UBound(Arr, 2)
                For K = 0 To 9
                    If InStr(Arr(X, Y), K) Then D(K) = D(K) + 1
                Next K
            Next Y
        Next X
        Arr = Application.Transpose(Array(D.keys, D.items))
        For X = 1 To UBound(Arr)
            Select Case Arr(X, 2)
                Case Is = 1
                    Crr(1, 1) = Crr(1, 1) & Arr(X, 1) & ","
                Case Is = 2
                    Crr(2, 1) = Crr(2, 1) & Arr(X, 1) & ","
                Case Is = 3
                    Crr(3, 1) = Crr(3, 1) & Arr(X, 1) & ","
                Case Is = 4
                    Crr(4, 1) = Crr(4, 1) & Arr(X, 1) & ","
            End Select
        Next X
        .Range("O11").Resize(4, 1) = ""
        .Range("O11").Resize(4, 1) = Crr
    End With
End Sub

hasyh2008

比我的方法好，学习了！

hasyh2008

运算没结果的原因是N11:N15要改为数值，不能为文本格式。
好像多了句d.RemoveAll

yearabc

hasyh2008 发表于 2022-6-8 23:14
Sub 统计()
    Dim Arr(), Brr, Crr(1 To 4, 1 To 1), X%, Y%, K%
    Dim Str$

谢谢，非常不错。我越来越理解了。实践才能提高

hasyh2008

原代码写的非常好，水平非常高，思路新颖，正在学习消化。

yearabc

hasyh2008 发表于 2022-6-9 00:47
运算没结果的原因是N11:N15要改为数值，不能为文本格式。
好像多了句d.RemoveAll

改为数值和常规，均不行，运算结果不显示。换一个电子表格就可以，真的十分不解。