求助陣列問題(頁 1) - Excel程式區

K0l1CHEN6 發表於 2020-10-8 17:54

求助陣列問題

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

Dim arr, i, j, k, m, n, p
      arr = [A1].CurrentRegion.Offset(1).Resize(, 9).Value
ReDim Sum(UBound(arr, 2)), t(UBound(arr, 2))

For i = 1 To UBound(arr, 1) - 1

      If arr(i, 2) <> arr(i + 1, 2) Then

         For j = 6 To UBound(arr, 2)
            Sum(j) = Sum(j)
            Debug.Print Sum(j)
         Next
      Else
         For j = 6 To UBound(arr, 2)
            Sum(j) = Sum(j) + arr(i, j)
            Debug.Print Sum(j)
         Next

      End If

         If arr(i + 1, 4) = "組合折扣" Then
            For j = p + 1 To i - 1
                  For k = 6 To UBound(arr, 2)
                     n = Round(-arr(i + 1, k) / Sum(k) * arr(j, k), 0)
                     arr(j, k) = arr(j, k) - n
                     t(k) = t(k) + n
                  Next
            Next

            For k = 6 To UBound(arr, 2)
                  arr(j, k) = arr(j, k) + arr(i + 1, k) + t(k)
                  Sum(k) = 0: t(k) = 0
            Next

            i = i + 1: p = i
         End If
Next

For i = 1 To UBound(arr, 1) - 1
      If arr(i, 4) <> "組合折扣" Then
         m = m + 1
         For j = 1 To UBound(arr, 2)
            arr(m, j) = arr(i, j)
         Next
      End If
Next

With [l2]
      .Resize(UBound(arr, 1), UBound(arr, 2)).ClearContents
      .Resize(m).NumberFormatLocal = "yyyymmdd"
      .Resize(m, UBound(arr, 2)) = arr
End With

End Sub[/code]

軒云熊 發表於 2020-10-8 23:35

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=113315&ptid=22805]1#[/url] [i]K0l1CHEN6[/i] [/b]
能否請你在上傳一次檔案我下載下來檔案是壞的不知道位啥我也想練習看看謝謝

K0l1CHEN6 發表於 2020-10-9 10:25

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=113318&ptid=22805]2#[/url] [i]軒云熊[/i] [/b]

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

[attach]32593[/attach]

軒云熊 發表於 2020-10-9 11:05

[i=s] 本帖最後由軒云熊於 2020-10-9 11:10 編輯 [/i]

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=113324&ptid=22805]3#[/url] [i]K0l1CHEN6[/i] [/b]

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

javascript:;

K0l1CHEN6 發表於 2020-10-9 13:38

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=113325&ptid=22805]4#[/url] [i]軒云熊[/i] [/b]

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

[attach]32595[/attach]

K0l1CHEN6 發表於 2020-10-10 10:25

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=113325&ptid=22805]4#[/url] [i]軒云熊[/i] [/b]

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

先將組別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

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=113330&ptid=22805]6#[/url] [i]K0l1CHEN6[/i] [/b]

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

有數量欄, 所以"單價"依比率扣是不符合邏輯的,
參考檔:
[attach]32599[/attach]

K0l1CHEN6 發表於 2020-10-10 12:55

K0l1CHEN6 發表於 2020-10-10 14:18

[quote]回復  K0l1CHEN6

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

有數量欄, 所以"單價"依比 ...
[size=2][color=#999999]准提部林發表於 2020-10-10 11:52[/color] [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=113334&ptid=22805][img]http://forum.twbts.com/images/common/back.gif[/img][/url][/size][/quote]

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

Dim arr, brr(), t
Set d = CreateObject("scripting.dictionary")
arr = [A1].CurrentRegion
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2)), t(UBound(arr, 2))

For i = 2 To UBound(arr)
      If Not d.exists(arr(i, 2)) Then
         k = k + 1
         d(arr(i, 2)) = k

         For j = 1 To UBound(arr, 2)
            brr(k, j) = arr(i, j)
         Next
      Else
         r = d(arr(i, 2))

         For j = 6 To UBound(arr, 2)
            If arr(i, j) < 0 Then
            Else
                  brr(r, j) = brr(r, j) + arr(i, j)
            End If
         Next
      End If
Next

For i = 1 To UBound(arr, 1) - 1
      If arr(i, 4) <> "組合折扣" Then
         m = m + 1

         For j = 1 To UBound(arr, 2)
            arr(m, j) = arr(i, j)
         Next

      End If
Next

With [K1]
      .Resize(UBound(arr, 1), UBound(arr, 2)).ClearContents
      .Resize(m).NumberFormatLocal = "yyyymmdd"
      .Resize(m, UBound(arr, 2)) = arr
End With

[U2].Resize(k, 9) = brr

End Sub[/code]

准提部林 發表於 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

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=113337&ptid=22805]10#[/url] [i]准提部林[/i] [/b]

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

准提部林 發表於 2020-10-10 17:36

K0l1CHEN6 發表於 2020-10-10 18:03

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=113339&ptid=22805]12#[/url] [i]准提部林[/i] [/b]

陣列的方法，小弟發現如果資料有空格的話不會被抓進陣列裡
所以小弟用了之前別的大大教的方式又再次修改了一下為[code] k = ThisWorkbook.Sheets(1).Cells.Find(What:="*", _
            After:=Range("A1"), _
            LookAt:=xlPart, _
            LookIn:=xlFormulas, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, _
            MatchCase:=False).Row

Arr = sh1.Range("A2:K" & k)[/code]

K0l1CHEN6 發表於 2020-10-10 18:03

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=113339&ptid=22805]12#[/url] [i]准提部林[/i] [/b]

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

K0l1CHEN6 發表於 2020-10-10 18:18

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

軒云熊 發表於 2020-10-10 22:49

[i=s] 本帖最後由軒云熊於 2020-10-10 23:02 編輯 [/i]

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=113342&ptid=22805]15#[/url] [i]K0l1CHEN6[/i] [/b]
有空幫我看一下是不是這樣謝謝[code]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[/code]javascript:;

軒云熊 發表於 2020-10-10 23:41

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=113342&ptid=22805]15#[/url] [i]K0l1CHEN6[/i] [/b]

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

Andy2483 發表於 2023-6-2 16:03

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=113337&ptid=22805]10#[/url] [i]准提部林[/i] [/b]

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

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

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

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

頁: [1]

麻辣家族討論版版's Archiver

求助陣列問題