K0l1CHEN6

回復 10# 准提部林

不愧是大大，用的程式碼比小弟精簡許多，但想要詢問一下使用"|"是因為要區隔不同欄位資料的關係嗎？

准提部林

回復 11# K0l1CHEN6


組別編號 654855
654855| > 主要的關鍵字---J=6 TO 9--- 654855|6 ~ 654855|9 --- 6~9欄各自獨立的加總
654855|S > 組合折扣的前綴關鍵字----654855|S6 ~ 654855|S9 --- 6~9欄組合折扣的金額

字典的KEYS用以上方法, 即可區分各項目的加總金額

K0l1CHEN6

回復 12# 准提部林


陣列的方法，小弟發現如果資料有空格的話不會被抓進陣列裡
所以小弟用了之前別的大大教的方式又再次修改了一下為

1.     k = ThisWorkbook.Sheets(1).Cells.Find(What:="*", _
   
2.                 After:=Range("A1"), _
   
3.                 LookAt:=xlPart, _
   
4.                 LookIn:=xlFormulas, _
   
5.                 SearchOrder:=xlByRows, _
   
6.                 SearchDirection:=xlPrevious, _
   
7.                 MatchCase:=False).Row
   
8.                
   
9.     Arr = sh1.Range("A2:K" & k)

複製代碼

K0l1CHEN6

回復 12# 准提部林


   感謝大大教學，非常感謝！

K0l1CHEN6

另外想請教一下，字典和陣列的方式須要如何判定哪一個是適合自己的呢？

軒云熊

回復 15# K0l1CHEN6
有空幫我看一下 是不是這樣 謝謝

1. Public Sub 陣列分組加總練習()
   
2. 
   
3. arr = Range(Cells(2, 2).End(xlDown), Cells(2, 2))
   
4. Set xD = CreateObject("Scripting.Dictionary")
   
5. For i = 1 To UBound(arr, 1)
   
6.     For j = 1 To UBound(arr, 2)
   
7.         xD(arr(i, j)) = arr(i, j)
   
8.     Next j
   
9. Next i
   
10. Erase arr
    
11. arr = Range("a1").CurrentRegion
    
12. ReDim Brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    
13. 
    
14. For Each X In xD
    
15.     ReDim Crr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    
16.     If IsArray(T) Then T = ""
    
17.     For A = 1 To UBound(arr, 1)
    
18.         For A1 = 1 To UBound(arr, 2)
    
19.             If arr(A, 2) = X Then
    
20.                 Crr(A, A1) = arr(A, A1)
    
21.             End If
    
22.         Next A1
    
23.     Next A
    
24. 
    
25.     k = 0: k1 = 0: k2 = 0: k3 = 0
    
26.     For A = 2 To UBound(Crr, 1)
    
27.         If Crr(A, 4) = "組合折扣" Then
    
28.            T = Array(Crr(A, 6), Crr(A, 7), Crr(A, 8), Crr(A, 9))
    
29.         End If
    
30.         If Crr(A, 2) = X Then
    
31.             If Crr(A, 4) <> "組合折扣" Then
    
32.                k = k + Crr(A, 6)
    
33.                k1 = k1 + Crr(A, 7)
    
34.                k2 = k2 + Crr(A, 8)
    
35.                k3 = k3 + Crr(A, 9)
    
36.             End If
    
37.         End If
    
38.     Next A
    
39.    
    
40.     For A = 2 To UBound(Crr, 1)
    
41.         If Crr(A, 4) <> "組合折扣" And Crr(A, 4) <> "" Then
    
42.             If Crr(A, 6) <> 0 And Crr(A, 7) <> 0 And Crr(A, 8) <> 0 And Crr(A, 9) <> 0 Then
    
43.                 If IsArray(T) Then
    
44.                     Brr(A - 1, 1) = (T(0) * Round(Crr(A, 6) / k, 3)) + Crr(A, 6)
    
45.                     Brr(A - 1, 2) = (T(1) * Round(Crr(A, 7) / k1, 3)) + Crr(A, 7)
    
46.                     Brr(A - 1, 3) = (T(2) * Round(Crr(A, 8) / k2, 3)) + Crr(A, 8)
    
47.                     Brr(A - 1, 4) = (T(3) * Round(Crr(A, 9) / k3, 3)) + Crr(A, 9)
    
48.                 End If
    
49.             End If
    
50.             If Not IsArray(T) Then
    
51.                 Brr(A - 1, 1) = k
    
52.                 Brr(A - 1, 2) = k1
    
53.                 Brr(A - 1, 3) = k2
    
54.                 Brr(A - 1, 4) = k3
    
55.             End If
    
56.         End If
    
57.     Next A
    
58. Next X
    
59.            
    
60. Set xD = Nothing
    
61. Erase arr, Crr, T
    
62. Range("K2").Resize(UBound(Brr, 1), UBound(Brr, 2)) = ""
    
63. Range("K2").Resize(UBound(Brr, 1), UBound(Brr, 2)) = Brr
    
64.       
    
65. End Sub

複製代碼

javascript:;

軒云熊

回復 15# K0l1CHEN6

剛剛發現 結果跟準大的不一樣   請問 沒有折扣的組別 要怎麼算? 可否舉列  我想知道答案 謝謝

Andy2483

回復 10# 准提部林


    謝謝論壇,謝謝前輩
後學藉此帖學習前輩的方案,方案學習心得註解如下,請前輩再指導

資料表:

下載 (206.5 KB)

2023-6-2 16:01

結果表:

下載 (234.77 KB)

2023-6-2 16:01

Sub TEST_A01()
Dim Arr, xD, i&, j%, N&, T$, U&
'↑宣告變數
Set xD = CreateObject("Scripting.Dictionary")
'↑令xD變數是 字典
Sheets("工作表2").UsedRange.EntireRow.Delete
'↑令表2使用儲存格所在的列刪除
Arr = Range([工作表1!I1], [工作表1!A1].Cells(Rows.Count, 1).End(xlUp))
'↑令Arr變數是 二維陣列,以表1的A~I欄儲存格值帶入陣列中
For i = 2 To UBound(Arr)
'↑設順迴圈
    T = Arr(i, 2) & "|"
    '↑令T變數是第2欄陣列值連接"|"符號的新字串
    If Arr(i, 4) = "組合折扣" Then T = T & "S"
    '↑如果第4欄陣列值是 "組合折扣"字串!就令T變數再連接"S"字元
    For j = 6 To 9:  xD(T & j) = xD(T & j) + Arr(i, j):  Next
    '↑設順迴圈!令T變數連接j迴圈數的新字串當key,
    '其item值各累加j變數當欄的Arr陣列值
Next i
'-----------------------------------
For i = 2 To UBound(Arr)
'↑設順迴圈
    If Arr(i, 4) = "組合折扣" Then GoTo i01
    '↑如果第4欄陣列值是 "組合折扣"字串!就不處理後續,跳到i01位置繼續執行
    T = Arr(i, 2) & "|"
    '↑令T變數是第2欄陣列值連接"|"符號的新字串,加"|"是防萬一
    N = N + 1
    '↑令N變數累加1(累加結果列數,一開始就+1是為了空出標題的列)
    For j = 1 To 5: Arr(N + 1, j) = Arr(i, j): Next
    '↑設順迴圈!令Arr陣列從第二列開始寫入結果值(1~5欄)
    For j = 6 To 9
    '↑設順迴圈
        Arr(N + 1, j) = Arr(i, j) + Arr(i, j) * (xD(T & "S" & j) / xD(T & j))
        '↑令6~9欄Arr陣列值結果列是
        '迴圈列個欄值+ 迴圈列個欄值*(組合折扣總金額/非組合折扣總金額)
        '計算組合折扣後平均價格(因為組合折扣值是負值,所以是用相加計算)
    Next j
i01: Next i
'-----------------------------------
[工作表2!A1:I1].Resize(N + 1) = Arr
'↑令表2寫入Arr陣列值,超過結果值的陣列值忽略
End Sub

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖學習陣列與字典,學習方案如下,請各前輩指教


Option Explicit
Sub TEST()
Dim Brr, Y, R&, i&, j%, T$, K$
Set Y = CreateObject("Scripting.Dictionary")
Sheets("工作表2").[A:I].ClearContents
Brr = Range([工作表1!I1], [工作表1!A65536].End(3))
K = "組合折扣"
For i = 2 To UBound(Brr)
   T = Brr(i, 4): T = Brr(i, 2) & "|" & IIf(T = K, K, "")
   For j = 6 To 9:  Y(T & j) = Y(T & j) + Brr(i, j):  Next
Next
For i = 2 To UBound(Brr)
   If Brr(i, 4) = K Then GoTo i01
   T = Brr(i, 2) & "|"
   R = R + 1
   For j = 1 To 5: Brr(R + 1, j) = Brr(i, j): Next
   For j = 6 To 9
       Brr(R + 1, j) = Brr(i, j) + Brr(i, j) * (Y(T & K & j) / Y(T & j))
   Next j
i01: Next i
[工作表2!A1:I1].Resize(R + 1) = Brr
Set Y = Nothing: Erase Brr
End Sub