[發問] 求助陣列問題

K0l1CHEN6

求助陣列問題，小弟嘗試過但無法正確分組陣列加總，還請求各位大大協助，謝謝！

1. Sub test()
   
2. 
   
3.     Dim arr, i, j, k, m, n, p
   
4.         arr = [A1].CurrentRegion.Offset(1).Resize(, 9).Value
   
5.     ReDim Sum(UBound(arr, 2)), t(UBound(arr, 2))
   
6.    
   
7.    
   
8.     For i = 1 To UBound(arr, 1) - 1
   
9.    
   
10.         If arr(i, 2) <> arr(i + 1, 2) Then
    
11.         
    
12.             For j = 6 To UBound(arr, 2)
    
13.                 Sum(j) = Sum(j)
    
14.                 Debug.Print Sum(j)
    
15.             Next
    
16.         Else
    
17.             For j = 6 To UBound(arr, 2)
    
18.                 Sum(j) = Sum(j) + arr(i, j)
    
19.                 Debug.Print Sum(j)
    
20.             Next
    
21. 
    
22.         End If
    
23.         
    
24.             If arr(i + 1, 4) = "組合折扣" Then
    
25.                 For j = p + 1 To i - 1
    
26.                     For k = 6 To UBound(arr, 2)
    
27.                         n = Round(-arr(i + 1, k) / Sum(k) * arr(j, k), 0)
    
28.                         arr(j, k) = arr(j, k) - n
    
29.                         t(k) = t(k) + n
    
30.                     Next
    
31.                 Next
    
32.             
    
33.                 For k = 6 To UBound(arr, 2)
    
34.                     arr(j, k) = arr(j, k) + arr(i + 1, k) + t(k)
    
35.                     Sum(k) = 0: t(k) = 0
    
36.                 Next
    
37.             
    
38.                 i = i + 1: p = i
    
39.             End If
    
40.     Next
    
41.    
    
42.     For i = 1 To UBound(arr, 1) - 1
    
43.         If arr(i, 4) <> "組合折扣" Then
    
44.             m = m + 1
    
45.             For j = 1 To UBound(arr, 2)
    
46.                 arr(m, j) = arr(i, j)
    
47.             Next
    
48.         End If
    
49.     Next
    
50.    
    
51.     With [l2]
    
52.         .Resize(UBound(arr, 1), UBound(arr, 2)).ClearContents
    
53.         .Resize(m).NumberFormatLocal = "yyyymmdd"
    
54.         .Resize(m, UBound(arr, 2)) = arr
    
55.     End With
    
56.    
    
57. End Sub

複製代碼

軒云熊

回復 1# K0l1CHEN6
能否請你在上傳一次檔案 我下載下來檔案是壞的 不知道位啥  我也想練習看看 謝謝

K0l1CHEN6

回復 2# 軒云熊

小弟剛剛重新下載下來開啟是正常的，重新上傳附檔為ZIP壓縮，再麻煩大大了感謝！

test1.zip (14.8 KB)

下載次數: 5

2020-10-9 10:24

軒云熊

回復 3# K0l1CHEN6

請問 是這樣的邏輯嗎? 或著 你把結果 放上來 我不太明白 抱歉 >"<  
組合折扣 公式 是怎麼算 我不明白


javascript:;

K0l1CHEN6

回復 4# 軒云熊


大大您好，以函數的公式呈現的話，用654856這組為例，
需要把未稅單價、未稅總價、總稅額和含稅總金額屏除"組合折扣"的金額先各別加總
再以每個值去除以總金額計算占比

下載 (77.7 KB)

2020-10-9 13:37

K0l1CHEN6

回復 4# 軒云熊


拍謝寫得不清楚，小弟是想要呈現

先將組別654856的未稅單價、未稅總價、總稅額和含稅總金額屏除組合折扣的金額加總，
1. 以未稅單價那欄為例，整欄加總金額為28762
2. 分別計算單項占比，以F2為例，6238/28762=0.217就是21.7%
3. 然後用那欄的折扣金額-285*0.217=-61.845，就可以算出折扣金額占比
4. 再將還沒計算折扣的6238+(-61.845)=6176.155
5. 分別計算每項扣除折扣金額後，最後再將折扣金額那行刪除

准提部林

回復 6# K0l1CHEN6

在Excel Home已發問好幾通, 無人回應,
應是沒人懂意思,

有數量欄, 所以"單價"依比率扣是不符合邏輯的,
參考檔:
test1-1.rar (11.31 KB)

下載次數: 3

2020-10-10 11:52

K0l1CHEN6

回復  K0l1CHEN6

在Excel Home已發問好幾通, 無人回應,
應是沒人懂意思,

有數量欄, 所以"單價"依比 ...
准提部林 發表於 2020-10-10 11:52

提供的資料為先前練習的檔案，故數字有出入，讓大大誤解真的是非常抱歉！
因Excel Home裡已經有大大幫小弟解答最重要的部分
但針對同組分別計算的話，小弟的理解是不是就是要再產生一個陣列來去單獨計算？

K0l1CHEN6

回復  K0l1CHEN6

在Excel Home已發問好幾通, 無人回應,
應是沒人懂意思,

有數量欄, 所以"單價"依比 ...
准提部林 發表於 2020-10-10 11:52

小弟成功嘗試略過組合折扣做加總，已經分離兩個數組
比較有嘗試不了的是如何將兩個陣列去做比對

1. Sub test1()
   
2. 
   
3.     Dim arr, brr(), t
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = [A1].CurrentRegion
   
6.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2)), t(UBound(arr, 2))
   
7.    
   
8.     For i = 2 To UBound(arr)
   
9.         If Not d.exists(arr(i, 2)) Then
   
10.             k = k + 1
    
11.             d(arr(i, 2)) = k
    
12.             
    
13.             For j = 1 To UBound(arr, 2)
    
14.                 brr(k, j) = arr(i, j)
    
15.             Next
    
16.         Else
    
17.             r = d(arr(i, 2))
    
18.             
    
19.             For j = 6 To UBound(arr, 2)
    
20.                 If arr(i, j) < 0 Then
    
21.                 Else
    
22.                     brr(r, j) = brr(r, j) + arr(i, j)
    
23.                 End If
    
24.             Next
    
25.         End If
    
26.     Next
    
27. 
    
28.     For i = 1 To UBound(arr, 1) - 1
    
29.         If arr(i, 4) <> "組合折扣" Then
    
30.             m = m + 1
    
31.             
    
32.             For j = 1 To UBound(arr, 2)
    
33.                 arr(m, j) = arr(i, j)
    
34.             Next
    
35.             
    
36.         End If
    
37.     Next
    
38.    
    
39.     With [K1]
    
40.         .Resize(UBound(arr, 1), UBound(arr, 2)).ClearContents
    
41.         .Resize(m).NumberFormatLocal = "yyyymmdd"
    
42.         .Resize(m, UBound(arr, 2)) = arr
    
43.     End With
    
44.    
    
45.     [U2].Resize(k, 9) = brr
    
46.    
    
47. End Sub

複製代碼

准提部林

Sub TEST_A01()
Dim Arr, xD, i&, j%, N&, T$, U&
Set xD = CreateObject("Scripting.Dictionary")
Sheets("工作表2").UsedRange.EntireRow.Delete
Arr = Range([工作表1!I1], [工作表1!A1].Cells(Rows.Count, 1).End(xlUp))
For i = 2 To UBound(Arr)
    T = Arr(i, 2) & "|"
    If Arr(i, 4) = "組合折扣" Then T = T & "S"
    For j = 6 To 9:  xD(T & j) = xD(T & j) + Arr(i, j):  Next
Next i
'-----------------------------------
For i = 2 To UBound(Arr)
    If Arr(i, 4) = "組合折扣" Then GoTo i01
    T = Arr(i, 2) & "|"
    N = N + 1
    For j = 1 To 5: Arr(N + 1, j) = Arr(i, j): Next
    For j = 6 To 9
        Arr(N + 1, j) = Arr(i, j) + Arr(i, j) * (xD(T & "S" & j) / xD(T & j))
    Next j
i01: Next i
'-----------------------------------
[工作表2!A1:I1].Resize(N + 1) = Arr
End Sub

test1-A01.rar (16.61 KB)

下載次數: 15

2020-10-10 15:42

小數不進位, 若要進位, 可能其加總後有因進1或退1所產生的誤差


'=====================================