相對複雜的條件計算平均值

15250150627

如題： TXET.rar (1.66 MB, 下载次数: 14)

2021-12-23 11:25 上传

点击文件名下载附件

因前期格式設定原因，導致現在求歷史平均值有點複雜了
附件內“機種數據庫工作表”需要更新“生產數據工作表”內的17列的歷史平均值
計算方式有寫出來了，但是有點繞，且不是很符合標準寫法，怕數據累計多了后會計算錯誤
機種數據庫工作表A：A   F2:N2  為求平均值條件，生產數據工作表內B:B  D:D為源數據條件，Q:Q為計算列
有試過用字典先增加KEY或去重（D&B）方式計算，但都卡在了字典計算完后無法拿出來放進機種數據庫工作表對應的位置。
所以想請大哥大姐們看一下，給個案列或者是意見！！！！
下面是我寫的計算代碼，目前計算出來的結果是對的，只是寫法有點取巧。

1. Private Sub Worksheet_Activate()
   
2. 'Sub sum()
   
3. Dim arr, brr, srr(), sht As Worksheet
   
4. Dim d As Object
   
5. Set sht = Sheet3
   
6. Set d = CreateObject("scripting.dictionary")
   
7.     n = sht.Range("a65536").End(xlUp).Row
   
8.     brr = sht.Range("a5:bz" & n)
   
9.     If brr(1, 1) = "" Then
   
10.         MsgBox "临ゼ块�Jネ玻计沮"
    
11.         Exit Sub
    
12.     End If
    
13.     Application.ScreenUpdating = False
    
14.     Application.EnableEvents = False
    
15.     n = Sheet5.Range("a65536").End(xlUp).Row
    
16.     Sheet5.Range("f3:n" & n).ClearContents
    
17.     arr = Sheet5.Range("a2:n" & n)
    
18.     s = 0: k = 0
    
19.     For i = 1 To 9
    
20.         m = i + 1
    
21.         s = m + 9
    
22.         t = s + 9
    
23.         For j = 1 To UBound(brr)
    
24.             tj = "L" & i
    
25.                 Key = brr(j, 4)
    
26.                 If brr(j, 2) = tj And brr(j, 17) <> "" Then
    
27.                     If d.exists(Key) Then
    
28.                        n = d(Key)
    
29.                        ReDim Preserve srr(1 To 29, 1 To d.Count)
    
30.                         srr(m, n) = brr(j, 2)
    
31.                         srr(s, n) = srr(s, n) + brr(j, 17): srr(t, n) = srr(t, n) + 1
    
32.                     Else
    
33.                        k = k + 1
    
34.                        d(Key) = k
    
35.                        ReDim Preserve srr(1 To 29, 1 To d.Count)
    
36.                        srr(1, k) = brr(j, 4): srr(m, k) = brr(j, 2)
    
37.                        srr(s, k) = srr(s, k) + brr(j, 17): srr(t, k) = srr(t, k) + 1
    
38.                     End If
    
39.                 End If
    
40.         Next j
    
41.     Next i
    
42.     For i = 2 To UBound(arr)
    
43.         For j = 6 To 14
    
44.             m = j - 4
    
45.             s = m + 9
    
46.             t = s + 9
    
47.             For x = 1 To UBound(srr, 2)
    
48.                 If arr(i, 1) = srr(1, x) Then
    
49.                    If arr(1, j) = srr(m, x) Then
    
50.                       arr(i, j) = srr(s, x) / srr(t, x)
    
51.                    End If
    
52.                 End If
    
53.             Next x
    
54.         Next j
    
55.     Next i
    
56.     Sheet5.Range("a2").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    
57.     Application.EnableEvents = True
    
58.     Application.ScreenUpdating = True
    
59. End Sub

复制代码

15250150627

另外附件內有很多種統計代碼，小弟剛學VBA，所以里面用了各種各樣的東西，不用感覺奇怪，只是為了多學習！

半百

这样可以吗？
    arr = Sheet5.Range("a2:n" & n)
For i = 1 To UBound(brr)
    If brr(i, 17) <> "" Then
        s = brr(i, 4) & "," & brr(i, 2)
        If Not d.EXISTS(s) Then
            d(s) = Array(brr(i, 17), 1)
        Else
            B = d(s)
            B(0) = B(0) + brr(i, 17)
            B(1) = B(1) + 1
            d(s) = B
        End If
    End If
Next
For j = 2 To UBound(arr)
    For k = 6 To 14
        s = arr(j, 1) & "," & arr(1, k)
        If d.EXISTS(s) Then
            B = d(s)
            arr(j, k) = B(0) / B(1)
        End If
    Next
Next
Sheet5.Range("a2").Resize(UBound(arr, 1), UBound(arr, 2)) = arr

15250150627

我研究下哦！
你這個看上去簡單多了