字典嵌套数组的问题

阿煮

grf1973 发表于 2024-7-19 15:55
姓名不应该作为分组依据吧。
这种要对数组进行筛选操作的，用Js方便很多。

虽然不会JS 但是很腻害  谢谢解答

usedrange

参与一下

1. Sub t()
   
2.     Dim arr, brr, v, ma, mi, m%, dic, r%, sh, av, ta, ti, res, h, k, ro%, rr%, q, wb
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     With Sheets("数据")
   
5.         m = .[a1].End(4).Row
   
6.         arr = .Range("a2:d" & m)
   
7.         For i = 1 To UBound(arr)
   
8.             dic(arr(i, 1)) = ""
   
9.         Next i
   
10.         ReDim brr(1 To dic.Count, 1 To 4)
    
11.         rr = 1
    
12.         For Each k In dic.keys
    
13.             r = WorksheetFunction.CountIf(.[a:a], k)
    
14.             ad = .[a:a].Find(what:=k).Address
    
15.             Set sh = .Range(ad).Resize(r, 4)
    
16.             q = r
    
17.             If r < 3 Then
    
18.                 v = WorksheetFunction.Average(sh(1, 2).Resize(r, 1))
    
19.             Else
    
20.                 ma = WorksheetFunction.Max(sh(1, 2).Resize(r, 1))
    
21.                 mi = WorksheetFunction.Min(sh(1, 2).Resize(r, 1))
    
22.                 If ma - mi < 21 Then
    
23.                     v = WorksheetFunction.Average(sh(1, 2).Resize(r, 1))
    
24.                 Else
    
25.                     av = WorksheetFunction.Average(sh(1, 2).Resize(r, 1))
    
26.                     ta = Abs(ma - av)
    
27.                     ti = Abs(mi - av)
    
28.                     res = WorksheetFunction.Max(ta, ti)
    
29.                     If ti = res Then h = mi Else h = ma
    
30.                     Set k1 = sh(1, 2).Resize(r, 1).Find(what:=h, lookat:=xlWhole)
    
31.                     Do While Not k1 Is Nothing
    
32.                         ro = k1.Row
    
33.                         Rows(ro).Delete
    
34.                         q = q - 1
    
35.                         Set k1 = sh(1, 2).Resize(q, 1).Find(what:=h, lookat:=xlWhole)
    
36.                     Loop
    
37.                 End If
    
38.             End If
    
39.             Set wb = .Range(ad).Resize(q, 4)
    
40.             If Not wb Is Nothing Then
    
41.                 brr(rr, 1) = k
    
42.                 brr(rr, 2) = wb(1, 3)
    
43.                 brr(rr, 3) = WorksheetFunction.CountIf(.[a:a], k)
    
44.                 brr(rr, 4) = WorksheetFunction.Average(wb(1, 2).Resize(q, 1))
    
45.                 rr = rr + 1
    
46.             End If
    
47.             Set sh = Nothing
    
48.             Set wb = Nothing
    
49.             Set k1 = Nothing
    
50.         Next k
    
51.         .[k2].Resize(UBound(brr), 4) = brr
    
52.     End With
    
53.     Set dic = Nothing
    
54. End Sub
    

复制代码

阿煮

usedrange 发表于 2024-7-20 14:30
参与一下

谢谢 学习下