今早搞错了，重求平均数量的代码，请老师帮助。

20090930

下面是合计数量代码，现求平均数量代码，求老师帮助。

Private Sub 合计数量_Click()

  Dim r%, i%
  Dim Arr, brr
  Dim d As Object
  Set d = CreateObject("scripting.dictionary")
  With Worksheets("sheet1")
    r = .Cells(.Rows.Count, 2).End(xlUp).Row
    .Range("E" & r + 1 & ":F65536").ClearContents
    Arr = .Range("B5:F" & r)
    For i = 1 To UBound(Arr)
      If Not d.Exists(Arr(i, 1)) Then
      ReDim brr(1 To 2)
      brr(1) = Arr(i, 1)
      Else
      brr = d(Arr(i, 1))
      End If
      brr(2) = brr(2) + Arr(i, 2)
      d(Arr(i, 1)) = brr
    Next i
   Range("E" & 5).Resize(d.Count, UBound(brr)) = Application.Transpose(Application.Transpose(d.Items))
End With
End Sub
附件：
附件.rar (10.97 KB, 下载次数: 2)

2018-9-18 16:07 上传

点击文件名下载附件

chxw68

建议楼主同一问题最好不要重复开贴，因为前面很多老师都帮忙写了代码，如果结果不对可以继续向帮助过的老师求教。

20090930

不好意思啊，因为与早前的要求不一样，有个我无法解决的问题，所以重求帮助。麻烦能打开附件给于帮助解决吗？

20090930

chxw68 发表于 2018-9-18 16:11
建议楼主同一问题最好不要重复开贴，因为前面很多老师都帮忙写了代码，如果结果不对可以继续向帮助过的老师 ...

不好意思啊，因为与早前的要求不一样，有个我无法解决的问题，所以重求帮助。麻烦能打开附件给于帮助解决吗？

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 2).End(xlUp).Row
   
8.     arr = .Range("b5:c" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       If Not d.exists(arr(i, 1)) Then
    
11.         ReDim brr(1 To 2)
    
12.       Else
    
13.         brr = d(arr(i, 1))
    
14.       End If
    
15.       If Len(arr(i, 2)) <> 0 Then
    
16.         brr(1) = brr(1) + 1
    
17.         brr(2) = brr(2) + arr(i, 2)
    
18.       End If
    
19.       d(arr(i, 1)) = brr
    
20.     Next
    
21.     m = 4
    
22.     For Each aa In d.keys
    
23.       m = m + 1
    
24.       brr = d(aa)
    
25.       .Cells(m, 5) = aa
    
26.       .Cells(m, 6) = brr(2)
    
27.       .Cells(m, 8) = aa
    
28.       If Len(brr(1)) <> 0 And brr(1) <> 0 Then
    
29.         .Cells(m, 9) = brr(2) / brr(1)
    
30.       End If
    
31.     Next
    
32.   End With
    
33. End Sub
    

复制代码

chxw68

一段代码都计算了。

20090930

chxw68 发表于 2018-9-18 17:09
一段代码都计算了。

多谢帮助多谢帮助