Board logo

標題: [發問] 求助陣列問題 [打印本頁]

作者: K0l1CHEN6    時間: 2020-10-8 17:54     標題: 求助陣列問題

求助陣列問題,小弟嘗試過但無法正確分組陣列加總,還請求各位大大協助,謝謝!
  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-8 23:35

回復 1# K0l1CHEN6
能否請你在上傳一次檔案 我下載下來檔案是壞的 不知道位啥  我也想練習看看 謝謝
作者: K0l1CHEN6    時間: 2020-10-9 10:25

回復 2# 軒云熊

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

[attach]32593[/attach]
作者: 軒云熊    時間: 2020-10-9 11:05

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

回復 3# K0l1CHEN6

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


javascript:;
作者: K0l1CHEN6    時間: 2020-10-9 13:38

回復 4# 軒云熊


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

[attach]32595[/attach]
作者: K0l1CHEN6    時間: 2020-10-10 10:25

回復 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. 分別計算每項扣除折扣金額後,最後再將折扣金額那行刪除
作者: 准提部林    時間: 2020-10-10 11:52

回復 6# K0l1CHEN6

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

有數量欄, 所以"單價"依比率扣是不符合邏輯的,
參考檔:
[attach]32599[/attach]
作者: K0l1CHEN6    時間: 2020-10-10 12:55

回復  K0l1CHEN6

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

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



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

回復  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
複製代碼

作者: 准提部林    時間: 2020-10-10 15:43

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

[attach]32600[/attach]

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


'=====================================
作者: K0l1CHEN6    時間: 2020-10-10 17:28

回復 10# 准提部林

不愧是大大,用的程式碼比小弟精簡許多,但想要詢問一下使用"|"是因為要區隔不同欄位資料的關係嗎?
作者: 准提部林    時間: 2020-10-10 17:36

回復 11# K0l1CHEN6


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

字典的KEYS用以上方法, 即可區分各項目的加總金額
作者: K0l1CHEN6    時間: 2020-10-10 18:03

回復 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    時間: 2020-10-10 18:03

回復 12# 准提部林


   感謝大大教學,非常感謝!
作者: K0l1CHEN6    時間: 2020-10-10 18:18

另外想請教一下,字典和陣列的方式須要如何判定哪一個是適合自己的呢?
作者: 軒云熊    時間: 2020-10-10 22:49

本帖最後由 軒云熊 於 2020-10-10 23:02 編輯

回復 15# K0l1CHEN6
有空幫我看一下 是不是這樣 謝謝
  1. Public Sub 陣列分組加總練習()

  2. arr = Range(Cells(2, 2).End(xlDown), Cells(2, 2))
  3. Set xD = CreateObject("Scripting.Dictionary")
  4. For i = 1 To UBound(arr, 1)
  5.     For j = 1 To UBound(arr, 2)
  6.         xD(arr(i, j)) = arr(i, j)
  7.     Next j
  8. Next i
  9. Erase arr
  10. arr = Range("a1").CurrentRegion
  11. ReDim Brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))

  12. For Each X In xD
  13.     ReDim Crr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
  14.     If IsArray(T) Then T = ""
  15.     For A = 1 To UBound(arr, 1)
  16.         For A1 = 1 To UBound(arr, 2)
  17.             If arr(A, 2) = X Then
  18.                 Crr(A, A1) = arr(A, A1)
  19.             End If
  20.         Next A1
  21.     Next A

  22.     k = 0: k1 = 0: k2 = 0: k3 = 0
  23.     For A = 2 To UBound(Crr, 1)
  24.         If Crr(A, 4) = "組合折扣" Then
  25.            T = Array(Crr(A, 6), Crr(A, 7), Crr(A, 8), Crr(A, 9))
  26.         End If
  27.         If Crr(A, 2) = X Then
  28.             If Crr(A, 4) <> "組合折扣" Then
  29.                k = k + Crr(A, 6)
  30.                k1 = k1 + Crr(A, 7)
  31.                k2 = k2 + Crr(A, 8)
  32.                k3 = k3 + Crr(A, 9)
  33.             End If
  34.         End If
  35.     Next A
  36.    
  37.     For A = 2 To UBound(Crr, 1)
  38.         If Crr(A, 4) <> "組合折扣" And Crr(A, 4) <> "" Then
  39.             If Crr(A, 6) <> 0 And Crr(A, 7) <> 0 And Crr(A, 8) <> 0 And Crr(A, 9) <> 0 Then
  40.                 If IsArray(T) Then
  41.                     Brr(A - 1, 1) = (T(0) * Round(Crr(A, 6) / k, 3)) + Crr(A, 6)
  42.                     Brr(A - 1, 2) = (T(1) * Round(Crr(A, 7) / k1, 3)) + Crr(A, 7)
  43.                     Brr(A - 1, 3) = (T(2) * Round(Crr(A, 8) / k2, 3)) + Crr(A, 8)
  44.                     Brr(A - 1, 4) = (T(3) * Round(Crr(A, 9) / k3, 3)) + Crr(A, 9)
  45.                 End If
  46.             End If
  47.             If Not IsArray(T) Then
  48.                 Brr(A - 1, 1) = k
  49.                 Brr(A - 1, 2) = k1
  50.                 Brr(A - 1, 3) = k2
  51.                 Brr(A - 1, 4) = k3
  52.             End If
  53.         End If
  54.     Next A
  55. Next X
  56.            
  57. Set xD = Nothing
  58. Erase arr, Crr, T
  59. Range("K2").Resize(UBound(Brr, 1), UBound(Brr, 2)) = ""
  60. Range("K2").Resize(UBound(Brr, 1), UBound(Brr, 2)) = Brr
  61.       
  62. End Sub
複製代碼
javascript:;
作者: 軒云熊    時間: 2020-10-10 23:41

回復 15# K0l1CHEN6

剛剛發現 結果跟準大的不一樣   請問 沒有折扣的組別 要怎麼算? 可否舉列  我想知道答案 謝謝
作者: Andy2483    時間: 2023-6-2 16:03

回復 10# 准提部林


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

資料表:
[attach]36507[/attach]

結果表:
[attach]36508[/attach]


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    時間: 2023-6-2 16:46

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


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




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)