统计列内不重复数字所对应列四个区个数最多的区域名

翁知江安

Sub test1()
Dim i, j, k, kk, s, imax, q As Integer
Dim pg, gg, pd, dd, t As String
Dim ar, br, cr, dr As Variant
Dim d, d1 As Object
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
ar = Sheets("sheet3").[b3].CurrentRegion
For i = 2 To UBound(ar)
   d(ar(i, 1)) = d(ar(i, 1)) + 1
Next
pg = "偏高": gg = "高": pd = "偏低": dd = "低"
For Each kk In d.keys
For i = 2 To UBound(ar)
  If ar(i, 1) = kk Then
    If ar(i, 2) >= 5 Then
    d1(kk & gg) = d1(kk & gg) + 1
     Else
       If ar(i, 2) >= 0 And ar(i, 2) < 5 Then
        d1(kk & pg) = d1(kk & pg) + 1
        Else
        If ar(i, 2) > -5 And ar(i, 2) < 0 Then
        d1(kk & pd) = d1(kk & pd) + 1
        Else
          d1(kk & dd) = d1(kk & dd) + 1
         End If
        End If
      End If
    End If
    Next
Next
Sheets("sheet3").[e2].Resize(1000, 7).ClearContents
Sheets("sheet3").[o2].Resize(2, 7).Copy Sheets("sheet3").[e2]
Sheets("sheet3").[e4].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
br = Sheets("sheet3").[e2].Resize(d.Count + 2, 7)
ReDim cr(1 To d.Count, 1 To 5)
For k = 3 To UBound(br)
   For j = 2 To 5
      cr(k - 2, j - 1) = d1(br(k, 1) & br(1, j))
    Next
    cr(k - 2, 5) = d(br(k, 1))
Next
Sheets("sheet3").[f4].Resize(d.Count, 5) = cr
br = Sheets("sheet3").[e2].Resize(d.Count + 2, 7)
ReDim dr(1 To d.Count, 1 To 1)
For k = 3 To UBound(br)
    imax = WorksheetFunction.Max(Sheets("sheet3").Cells(k + 1, 6).Resize(1, 4))
    For j = 2 To 5
    If br(k, j) = imax Then
      q = q + 1
      If q = 1 Then
       t = t & br(1, j)
       Else
       t = t & ";" & br(1, j)
       End If
    End If
    Next
    dr(k - 2, 1) = t
    t = "": q = 0
Next
Sheets("sheet3").[k4].Resize(d.Count, 1) = dr
Sheets("sheet3").[e3].Select
Sheets("sheet3").[e3].Resize(d.Count + 1, 7).Sort key1:=Columns("e"), order1:=xlDescending, Header:=xlYes
MsgBox "ok"
End Sub

quqiyuan

参与一下，仅供参考。。。
顺带排序了

quqiyuan

代码如下。。。
Sub test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    t = Timer
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet3")
    arr = sht.[b3].CurrentRegion
    数值名称 = [{"偏高","高","偏低","低","总数（个）","最高数值名称"}]
    Set d = CreateObject("scripting.dictionary")
    ReDim brr(1 To UBound(arr), 1 To 7)
    For i = 2 To UBound(arr)
        s = arr(i, 1): ss = arr(i, 2)
        If Not d.exists(s) Then
            n = n + 1
            d(s) = n
        End If
        m = d(s)
        If ss >= 0 And ss < 5 Then brr(m, 2) = brr(m, 2) + 1
        If ss >= 5 Then brr(m, 3) = brr(m, 3) + 1
        If ss > -5 And ss < 0 Then brr(m, 4) = brr(m, 4) + 1
        If ss <= -5 Then brr(m, 5) = brr(m, 5) + 1
    Next
    Key = d.keys
    For i = 1 To n
        s = Empty
        x = Application.Max(Application.Index(brr, i))
        For j = 2 To 5
            If brr(i, j) = x Then s = s & "：" & 数值名称(j - 1)
            brr(i, 6) = brr(i, 6) + brr(i, j)
        Next
        brr(i, 7) = Mid(s, 2)
        brr(i, 1) = Key(i - 1)
    Next
    With wb.Sheets("sheet2")
        .Cells.Clear
        .[b1].Resize(, 6) = 数值名称
        .[a2:e2] = [{"度","0≤数字1＜5","数字2≥5","0＞数字3＞-5","数字4≤-5"}]
        .[a3].Resize(n, 7) = brr
        .UsedRange.HorizontalAlignment = xlCenter
        .UsedRange.Columns.AutoFit
        Set Rng = .[a3].Resize(n, 7)
        Rng.Sort Key1:=.[a3], Order1:=xlAscending, Header:=xlNo
        .UsedRange.Borders.LineStyle = 1
        .[f1:f2].Merge
        .[g1:g2].Merge
    End With
    Set d = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "共耗时：" & Format(Timer - t, "0.0000") & " 秒！！！", 64
End Sub

翁知江安

供参考，欢迎批评指正（对个别内容进行了调整），结果已标色

一招秒杀

1句6行，小于0.1秒，这个如何

乐开花36

利用第一组统计出的样本（SHEET2),对第二组正确率进行测试；具体步骤如左边，手工示范了一下，不会VAB，老师们看看如何用代码计算，谢谢
区名称3.zip (98.15 KB, 下载次数: 5)

2025-3-23 10:59 上传

点击文件名下载附件

戎马书生222

"度"列里的77，对应着不同的幅，一个是10一个是8

乐开花36

戎马书生222 发表于 2025-3-23 11:11
"度"列里的77，对应着不同的幅，一个是10一个是8

第一组目的是统计后，制定判断标准。完成后，用工作表sheet2标准，对第二组进行测试，判断正确率。

戎马书生222

也不知道对吧。代码如下：

1. Sub abey()
   
2. Dim arr, brr, i&, j&, k&, r&, m&
   
3. Set d = VBA.CreateObject("scripting.dictionary")
   
4. arr = [a1].CurrentRegion
   
5. ReDim brr(1 To UBound(arr), 1 To 8)
   
6. brr(1, 2) = "偏高": brr(1, 3) = "高": brr(1, 4) = "偏低": brr(1, 5) = "低": brr(1, 6) = "总数（个）": brr(1, 7) = "最高数值所在区域"
   
7. brr(2, 1) = "度": brr(2, 2) = "大于等于5": brr(2, 3) = "大于等于0小于5": brr(2, 4) = "大于-5小于0": brr(2, 5) = "小于等于-5"
   
8. r = 2
   
9. For i = 2 To UBound(arr)
   
10.     s = arr(i, 1)
    
11.     If Not d.exists(s) Then
    
12.         r = r + 1
    
13.         d(s) = r
    
14.         brr(r, 1) = s
    
15.     End If
    
16.     m = d(s)
    
17.     count1 = arr(i, 2)
    
18.     If count1 >= 5 Then
    
19.         brr(m, 2) = brr(m, 2) + 1
    
20.     ElseIf count1 >= 0 And count1 < 5 Then
    
21.         brr(m, 3) = brr(m, 3) + 1
    
22.     ElseIf count1 < 0 And count1 > -5 Then
    
23.         brr(m, 4) = brr(m, 4) + 1
    
24.     ElseIf count1 <= -5 Then
    
25.         brr(m, 5) = brr(m, 5) + 1
    
26.     End If
    
27. 
    
28. Next i
    
29. 
    
30. d.RemoveAll
    
31. For i = 3 To UBound(brr)
    
32.     For k = 2 To 5
    
33.         brr(i, 6) = brr(i, 6) + brr(i, k)
    
34.         brr(i, 8) = WorksheetFunction.Max(brr(i, 2), brr(i, 3), brr(i, 4), brr(i, 5))
    
35.         If Not d.exists(brr(i, 1)) Then
    
36.             If brr(i, k) = brr(i, 8) Then
    
37.                 d(brr(i, 1) & brr(i, 8)) = k
    
38.                 brr(i, 7) = brr(1, d(brr(i, 1) & brr(i, 8)))
    
39.             End If
    
40.         End If
    
41.         
    
42.     Next k
    
43.    
    
44.    
    
45. Next i
    
46. [g1].Resize(r + 2, 7) = brr
    
47. Stop
    
48. End Sub
    

复制代码

戎马书生222

或者用这种思路也行。

1. Sub abey()
   
2. Dim arr, brr, i&, j&, k&, r&, m&
   
3. Set d = VBA.CreateObject("scripting.dictionary")
   
4. arr = [a1].CurrentRegion
   
5. ReDim brr(1 To UBound(arr), 1 To 8)
   
6. brr(1, 2) = "偏高": brr(1, 3) = "高": brr(1, 4) = "偏低": brr(1, 5) = "低": brr(1, 6) = "总数（个）": brr(1, 7) = "最高数值所在区域"
   
7. brr(2, 1) = "度": brr(2, 2) = "X>=5": brr(2, 3) = "0<=X<5": brr(2, 4) = "-5<X<0": brr(2, 5) = "X<=-5"
   
8. r = 2
   
9. For i = 2 To UBound(arr)
   
10.     s = arr(i, 1)
    
11.     ss = arr(i, 2)
    
12.     If Not d.exists(s) Then
    
13.         r = r + 1
    
14.         d(s) = Array(ss, r, 1)
    
15.     Else
    
16.         d(s) = Array(ss, d(s)(1), d(s)(2) + 1)
    
17.     End If
    
18.     Count1 = d(s)(0)
    
19.     m = d(s)(1)
    
20.     If Count1 >= 5 Then
    
21.         brr(m, 2) = brr(m, 2) + 1
    
22.     ElseIf Count1 >= 0 And Count1 < 5 Then
    
23.         brr(m, 3) = brr(m, 3) + 1
    
24.     ElseIf Count1 < 0 And Count1 > -5 Then
    
25.         brr(m, 4) = brr(m, 4) + 1
    
26.     ElseIf Count1 <= -5 Then
    
27.         brr(m, 5) = brr(m, 5) + 1
    
28.     End If
    
29.     brr(m, 1) = s
    
30.     brr(m, 6) = d(s)(2)
    
31. Next i
    
32. d.RemoveAll
    
33. For i = 3 To UBound(brr)
    
34.     For j = 2 To 5
    
35.         maxcnt = WorksheetFunction.Max(brr(i, 2), brr(i, 3), brr(i, 4), brr(i, 5))
    
36.         If brr(i, j) = maxcnt Then
    
37.            d(brr(i, 1)) = j
    
38.            brr(i, 7) = brr(1, d(brr(i, 1)))
    
39.         End If
    
40.         
    
41.     Next j
    
42. Next i
    
43. [g1].Resize(d.Count + 2, 7) = brr
    
44. With [g1].Resize(d.Count + 2, 7)
    
45.     .BorderAround LineStyle:=xlContinuous, Weight:=xlThick
    
46.     ' 内部边框：虚线
    
47.     .Borders(xlInsideHorizontal).LineStyle = xlDash
    
48.     .Borders(xlInsideVertical).LineStyle = xlDash
    
49.     .HorizontalAlignment = xlCenter
    
50.     .VerticalAlignment = xlCenter
    
51. End With
    
52. 
    
53. End Sub

复制代码