返回列表 上一主題 發帖

[發問] 求助陣列問題

[發問] 求助陣列問題

求助陣列問題,小弟嘗試過但無法正確分組陣列加總,還請求各位大大協助,謝謝!
  1. Sub test()

  2.     Dim arr, i, j, k, m, n, p
  3.         arr = [A1].CurrentRegion.Offset(1).Resize(, 9).Value
  4.     ReDim Sum(UBound(arr, 2)), t(UBound(arr, 2))
  5.    
  6.    
  7.     For i = 1 To UBound(arr, 1) - 1
  8.    
  9.         If arr(i, 2) <> arr(i + 1, 2) Then
  10.         
  11.             For j = 6 To UBound(arr, 2)
  12.                 Sum(j) = Sum(j)
  13.                 Debug.Print Sum(j)
  14.             Next
  15.         Else
  16.             For j = 6 To UBound(arr, 2)
  17.                 Sum(j) = Sum(j) + arr(i, j)
  18.                 Debug.Print Sum(j)
  19.             Next

  20.         End If
  21.         
  22.             If arr(i + 1, 4) = "組合折扣" Then
  23.                 For j = p + 1 To i - 1
  24.                     For k = 6 To UBound(arr, 2)
  25.                         n = Round(-arr(i + 1, k) / Sum(k) * arr(j, k), 0)
  26.                         arr(j, k) = arr(j, k) - n
  27.                         t(k) = t(k) + n
  28.                     Next
  29.                 Next
  30.             
  31.                 For k = 6 To UBound(arr, 2)
  32.                     arr(j, k) = arr(j, k) + arr(i + 1, k) + t(k)
  33.                     Sum(k) = 0: t(k) = 0
  34.                 Next
  35.             
  36.                 i = i + 1: p = i
  37.             End If
  38.     Next
  39.    
  40.     For i = 1 To UBound(arr, 1) - 1
  41.         If arr(i, 4) <> "組合折扣" Then
  42.             m = m + 1
  43.             For j = 1 To UBound(arr, 2)
  44.                 arr(m, j) = arr(i, j)
  45.             Next
  46.         End If
  47.     Next
  48.    
  49.     With [l2]
  50.         .Resize(UBound(arr, 1), UBound(arr, 2)).ClearContents
  51.         .Resize(m).NumberFormatLocal = "yyyymmdd"
  52.         .Resize(m, UBound(arr, 2)) = arr
  53.     End With
  54.    
  55. End Sub
複製代碼
2020-10-06_190331.png

test1.rar (13.87 KB)

模擬文件

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

TOP

回復 2# 軒云熊

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

test1.zip (14.8 KB)

TOP

本帖最後由 軒云熊 於 2020-10-9 11:10 編輯

回復 3# K0l1CHEN6

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


javascript:;
1009.png

TOP

回復 4# 軒云熊


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

2020-10-09_133438.png
2020-10-9 13:37

TOP

回復 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. 分別計算每項扣除折扣金額後,最後再將折扣金額那行刪除

TOP

回復 6# K0l1CHEN6

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

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

TOP

回復  K0l1CHEN6

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

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



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

TOP

回復  K0l1CHEN6

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

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





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

  2.     Dim arr, brr(), t
  3.     Set d = CreateObject("scripting.dictionary")
  4.     arr = [A1].CurrentRegion
  5.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2)), t(UBound(arr, 2))
  6.    
  7.     For i = 2 To UBound(arr)
  8.         If Not d.exists(arr(i, 2)) Then
  9.             k = k + 1
  10.             d(arr(i, 2)) = k
  11.             
  12.             For j = 1 To UBound(arr, 2)
  13.                 brr(k, j) = arr(i, j)
  14.             Next
  15.         Else
  16.             r = d(arr(i, 2))
  17.             
  18.             For j = 6 To UBound(arr, 2)
  19.                 If arr(i, j) < 0 Then
  20.                 Else
  21.                     brr(r, j) = brr(r, j) + arr(i, j)
  22.                 End If
  23.             Next
  24.         End If
  25.     Next

  26.     For i = 1 To UBound(arr, 1) - 1
  27.         If arr(i, 4) <> "組合折扣" Then
  28.             m = m + 1
  29.             
  30.             For j = 1 To UBound(arr, 2)
  31.                 arr(m, j) = arr(i, j)
  32.             Next
  33.             
  34.         End If
  35.     Next
  36.    
  37.     With [K1]
  38.         .Resize(UBound(arr, 1), UBound(arr, 2)).ClearContents
  39.         .Resize(m).NumberFormatLocal = "yyyymmdd"
  40.         .Resize(m, UBound(arr, 2)) = arr
  41.     End With
  42.    
  43.     [U2].Resize(k, 9) = brr
  44.    
  45. End Sub
複製代碼

TOP

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)

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


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

TOP

        靜思自在 : 忘功不忘過,忘怨不忘恩。
返回列表 上一主題