- 帖子
- 254
- 主題
- 6
- 精華
- 0
- 積分
- 310
- 點名
- 0
- 作業系統
- W10
- 軟體版本
- Excel 2016
- 閱讀權限
- 20
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2019-6-16
- 最後登錄
- 2025-6-21
|
本帖最後由 軒云熊 於 2020-10-10 23:02 編輯
回復 15# K0l1CHEN6
有空幫我看一下 是不是這樣 謝謝- Public Sub 陣列分組加總練習()
- arr = Range(Cells(2, 2).End(xlDown), Cells(2, 2))
- Set xD = CreateObject("Scripting.Dictionary")
- For i = 1 To UBound(arr, 1)
- For j = 1 To UBound(arr, 2)
- xD(arr(i, j)) = arr(i, j)
- Next j
- Next i
- Erase arr
- arr = Range("a1").CurrentRegion
- ReDim Brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
- For Each X In xD
- ReDim Crr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
- If IsArray(T) Then T = ""
- For A = 1 To UBound(arr, 1)
- For A1 = 1 To UBound(arr, 2)
- If arr(A, 2) = X Then
- Crr(A, A1) = arr(A, A1)
- End If
- Next A1
- Next A
- k = 0: k1 = 0: k2 = 0: k3 = 0
- For A = 2 To UBound(Crr, 1)
- If Crr(A, 4) = "組合折扣" Then
- T = Array(Crr(A, 6), Crr(A, 7), Crr(A, 8), Crr(A, 9))
- End If
- If Crr(A, 2) = X Then
- If Crr(A, 4) <> "組合折扣" Then
- k = k + Crr(A, 6)
- k1 = k1 + Crr(A, 7)
- k2 = k2 + Crr(A, 8)
- k3 = k3 + Crr(A, 9)
- End If
- End If
- Next A
-
- For A = 2 To UBound(Crr, 1)
- If Crr(A, 4) <> "組合折扣" And Crr(A, 4) <> "" Then
- If Crr(A, 6) <> 0 And Crr(A, 7) <> 0 And Crr(A, 8) <> 0 And Crr(A, 9) <> 0 Then
- If IsArray(T) Then
- Brr(A - 1, 1) = (T(0) * Round(Crr(A, 6) / k, 3)) + Crr(A, 6)
- Brr(A - 1, 2) = (T(1) * Round(Crr(A, 7) / k1, 3)) + Crr(A, 7)
- Brr(A - 1, 3) = (T(2) * Round(Crr(A, 8) / k2, 3)) + Crr(A, 8)
- Brr(A - 1, 4) = (T(3) * Round(Crr(A, 9) / k3, 3)) + Crr(A, 9)
- End If
- End If
- If Not IsArray(T) Then
- Brr(A - 1, 1) = k
- Brr(A - 1, 2) = k1
- Brr(A - 1, 3) = k2
- Brr(A - 1, 4) = k3
- End If
- End If
- Next A
- Next X
-
- Set xD = Nothing
- Erase arr, Crr, T
- Range("K2").Resize(UBound(Brr, 1), UBound(Brr, 2)) = ""
- Range("K2").Resize(UBound(Brr, 1), UBound(Brr, 2)) = Brr
-
- End Sub
|
|
發表於 2020-10-8 23:35
| 
