VBA用两种方法 按姓名计数与产量平均值

laoau138

VBA用两种方法   按姓名计数与产量平均值

一沫昔阳虹w

1. Sub UsingArray()
   
2.     Dim rng As Range, arr(), brr(), i As Integer, j As Integer, k As Integer, n As Integer
   
3.     arr = Range([b2], Cells(Rows.Count, 3).End(xlUp))
   
4.     n = 1
   
5.     For i = 1 To UBound(arr)
   
6.             ReDim Preserve brr(1 To 3, 1 To n)  '保留已有值
   
7.             For j = 1 To UBound(brr, 2)
   
8.                     If brr(1, j) <> arr(i, 1) Then  '判断
   
9.                             k = k + 1
   
10.                     Else
    
11.                             brr(2, j) = brr(2, j) + 1  '夺冠次数
    
12.                             brr(3, j) = brr(3, j) + arr(i, 2)  '总产量累加
    
13.                     End If
    
14.             Next
    
15.             If k = n Then   '内层循环brr数组2维上标次，说明是新值
    
16.                     brr(1, n) = arr(i, 1)   '初始化
    
17.                     brr(2, n) = 1
    
18.                     brr(3, n) = arr(i, 2)
    
19.                     n = n + 1
    
20.             End If
    
21.             k = 0   '初始化
    
22.     Next
    
23.     '--------------------------------------------
    
24.     For i = 1 To UBound(brr, 2) - 1
    
25.             brr(3, i) = brr(3, i) / brr(2, i)   '求平均值
    
26.     Next
    
27.     '----------------------------------------------
    
28.     Range("e2").Resize(UBound(brr, 2), 3) = Application.Transpose(brr)
    
29.    
    
30. 
    
31. End Sub

复制代码

一沫昔阳虹w

修改了一下

1. Option Explicit
   
2. 
   
3. Sub UsingArray()
   
4.     On Error Resume Next
   
5.     Dim rng As Range, arr(), brr(), i As Integer, j As Integer, k As Integer, n As Integer
   
6.     arr = Range([b2], Cells(Rows.Count, 3).End(xlUp))
   
7.     n = 1
   
8.     For i = 1 To UBound(arr)
   
9.             ReDim Preserve brr(1 To 3, 1 To n)  '保留已有值
   
10.             For j = 1 To UBound(brr, 2)
    
11.                     If brr(1, j) <> arr(i, 1) Then  '判断
    
12.                             k = k + 1
    
13.                     Else
    
14.                             brr(2, j) = brr(2, j) + 1  '夺冠次数
    
15.                             brr(3, j) = brr(3, j) + arr(i, 2)  '总产量累加
    
16.                     End If
    
17.             Next
    
18.             If k = n Then   '内层循环brr数组2维上标次，说明是新值
    
19.                     brr(1, n) = arr(i, 1)   '初始化
    
20.                     brr(2, n) = 1
    
21.                     brr(3, n) = arr(i, 2)
    
22.                     n = n + 1
    
23.             End If
    
24.             k = 0   '初始化
    
25.     Next
    
26.     '--------------------------------------------
    
27.     For i = 1 To UBound(brr, 2)
    
28.             brr(3, i) = brr(3, i) / brr(2, i)   '求平均值
    
29.     Next
    
30.     '----------------------------------------------
    
31.     Range("e2").Resize(UBound(brr, 2), 3) = Application.Transpose(brr)
    
32.    
    
33. 
    
34. End Sub
    
35. 
    
36. 
    
37. Sub UsingDictionary()
    
38.     Dim rng As Range, arr(), brr(), i As Integer, j As Integer, k As Integer, n As Integer
    
39.     Dim d1 As Object, d2 As Object, arr2, arr3
    
40.     arr = Range([b2], Cells(Rows.Count, 3).End(xlUp))
    
41.     Set d1 = CreateObject("scripting.dictionary") '定义字典
    
42.     Set d2 = CreateObject("scripting.dictionary") '定义字典
    
43.     '------------------------------------------
    
44.     For i = 1 To UBound(arr)
    
45.             d1(arr(i, 1)) = d1(arr(i, 1)) + arr(i, 2)     '修改键的对应的item值
    
46.             d2(arr(i, 1)) = d2(arr(i, 1)) + 1     '记录次数
    
47.     Next
    
48.     '------------------------------------------
    
49.     arr2 = d1.items
    
50.     arr3 = d2.items
    
51.     For i = 0 To d1.Count - 1   '求平均值
    
52.             arr2(i) = arr2(i) / arr3(i)     '好像不能直接使用d1.Item(i)
    
53.     Next
    
54.     '------------------------------------------
    
55.     Range("e2").Resize(d1.Count) = Application.Transpose(d1.Keys)
    
56.     Range("f2").Resize(d1.Count) = Application.Transpose(d2.items)
    
57.     Range("g2").Resize(d1.Count) = Application.Transpose(arr2)
    
58.    
    
59. End Sub
    

复制代码

laoau138

一沫昔阳虹w 发表于 2016-12-14 18:05
修改了一下

做得好，谢高手

laoau138

一沫昔阳虹w 发表于 2016-12-14 18:05
修改了一下

VBA用数组把单元格用select选择起来


http://www.excelpx.com/thread-426449-1-1.html

laoau138

一沫昔阳虹w 发表于 2016-12-14 18:05
修改了一下

VBA查找最小值等于50的所有单元格


http://www.excelpx.com/thread-426472-1-1.html

laoau138

一沫昔阳虹w 发表于 2016-12-14 17:15

VBA蓝底单元格输入数字全排列   然后再容错

http://www.excelpx.com/thread-427027-1-1.html