cypd

回復 10# 星空乂羽翼

  非常感謝 星空乂羽翼 熱心@回覆
非常神奇的涵數公式
比對符合要件之後相乘相加...
希望筆數若多不影響運算...感恩解答  ^^

Andy2483

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

執行結果:

下載 (130.08 KB)

2023-6-28 08:32

Sub TEST()
Dim Brr, V4&, V5&, Z, i&, T$, A&, Af&, B$, Bn&, D&, Df, Ra As Range
Set Z = CreateObject("Scripting.Dictionary")
Set Ra = Range([工作表1!H3], [工作表1!A65536].End(3)): Brr = Ra
For i = 1 To UBound(Brr)
   T = Brr(i, 3): V4 = Val(Brr(i, 4)): V5 = Val(Brr(i, 5))
   If V4 > 0 Then
      A = Z(T & "|進"): A = A + V4: Z(T & "|進") = A
      Af = Z(T & "|進額"): Af = Af + V4 * Val(Brr(i, 6))
      Z(T & "|進額") = Af
   End If
   Bn = Val(Brr(i, 8))
   If Bn > 0 Then
      B = Z(T & "|贈敘")
      Z(T & "|贈數") = Z(T & "|贈數") + Bn
      If B = "" Then
         B = Brr(i, 1) & "項_" & Brr(i, 2) & "_贈_" & Bn
         Else
         B = B & " ★" & Brr(i, 1) & "項_" & Brr(i, 2) & "_贈_" & Bn
      End If
      Z(T & "|贈敘") = B: B = ""
   End If
   If V5 > 0 Then
      D = Z(T & "|銷"): D = D + V5: Z(T & "|銷") = D
      Df = Z(T & "|銷額"): Df = Df + V5 * Val(Brr(i, 6))
      Z(T & "|銷額") = Df
   End If
Next
Set Ra = Range([工作表1!S2], [工作表1!M65536].End(3)): Brr = Ra
For i = 2 To UBound(Brr)
   T = Brr(i, 1)
   Brr(i, 2) = Z(T & "|進")
   Brr(i, 3) = Z(T & "|銷") + Z(T & "|贈數")
   Brr(i, 4) = Brr(i, 2) - Brr(i, 3)
   Brr(i, 5) = Z(T & "|進額")
   Brr(i, 6) = Z(T & "|銷額")
   Brr(i, 7) = Z(T & "|贈敘")
Next
Ra = Brr: [S2] = "備註"
Set Z = Nothing: Erase Brr: Set Ra = Nothing
End Sub

hcm19522

https://www.blogger.com/blog/pos ... /787676332473588008

cypd

回復 13# hcm19522

不好意思  hcm19522

無法登入呢  ?

cypd

回復 12# Andy2483

非常感謝前輩  Andy2483  熱心解答
關於此問有以下補充
※是否能增加盈虧金額一欄 ( T 欄)

另外 U 欄備註贈品數之註記
同一商品因不同銷貨日期所致
若筆數增多...U備註欄內容文字會隨之拖長問題  ?

下載 (149.43 KB)

2023-6-28 13:48

Andy2483

回復 15# cypd


    謝謝前輩回復
後學學習方案如下,請前輩參考

執行結果:

下載 (136.29 KB)

2023-6-28 14:44

Sub TEST()
Dim Brr, V4&, V5&, Z, i&, T$, A&, Af&, B$, Bn&, D&, Df, Ra As Range
Set Z = CreateObject("Scripting.Dictionary")
Set Ra = Range([工作表1!H3], [工作表1!A65536].End(3)): Brr = Ra
For i = 1 To UBound(Brr)
   T = Brr(i, 3): V4 = Val(Brr(i, 4)): V5 = Val(Brr(i, 5))
   If V4 > 0 Then
      A = Z(T & "|進"): A = A + V4: Z(T & "|進") = A
      Af = Z(T & "|進額"): Af = Af + V4 * Val(Brr(i, 6))
      Z(T & "|進額") = Af
   End If
   Bn = Val(Brr(i, 8))
   If Bn > 0 Then
      B = Z(T & "|贈敘")
      Z(T & "|贈數") = Z(T & "|贈數") + Bn
      If B = "" Then
         B = Brr(i, 1) & "項_" & Brr(i, 2) & "_贈_" & Bn
         Else
         B = B & " ★" & Brr(i, 1) & "項_" & Brr(i, 2) & "_贈_" & Bn
      End If
      Z(T & "|贈敘") = B: B = ""
   End If
   If V5 > 0 Then
      D = Z(T & "|銷"): D = D + V5: Z(T & "|銷") = D
      Df = Z(T & "|銷額"): Df = Df + V5 * Val(Brr(i, 6))
      Z(T & "|銷額") = Df
   End If
Next
Set Ra = Range([工作表1!V2], [工作表1!N65536].End(3)): Brr = Ra
For i = 2 To UBound(Brr)
   T = Brr(i, 1)
   Brr(i, 2) = Z(T & "|進")
   Brr(i, 3) = Z(T & "|銷") + Z(T & "|贈數")
   Brr(i, 4) = Brr(i, 2) - Brr(i, 3)
   Brr(i, 5) = Z(T & "|進額")
   Brr(i, 6) = Z(T & "|銷額")
   Brr(i, 7) = Brr(i, 6) - Brr(i, 5)
   Brr(i, 8) = "共贈出: " & Z(T & "|贈數")
   Brr(i, 9) = Z(T & "|贈敘")
Next
Ra = Brr: [U2] = "備註"
Set Z = Nothing: Erase Brr: Set Ra = Nothing
End Sub

cypd

回復 16# Andy2483

非常感謝前輩  Andy2483  熱心解答
若是不經執行巨集之動作
而是工作表內儲存格D(進貨)E(銷貨)F(單價)H(贈品)等相關欄位輸入數據或異動
觸發事件就會執行VBA…該程式如何修正  ??
Private Sub Worksheet_Change(ByVal Target As Range)

Andy2483

回復 17# cypd


    謝謝前輩再回復
以下觸發學習方案請前輩參考


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xR As Range
With Target
   Set xR = Intersect([A:H], ActiveSheet.UsedRange)
   If Not Intersect(.Cells, xR) Is Nothing Then Call TEST
End With
Set xR = Nothing
End Sub

星空乂羽翼

建議M欄資料可用函數去抓出C欄名稱的資料
並刪除重複資料。

若版本為2021以上的版本
建議可以用UNIQUE函數

於M3儲存格輸入以下公式
=UNIQUE(C3:C32)

cypd

回復 18# Andy2483

非常感謝前輩  Andy2483  熱心提供解答
觸發學習方案相關公式經實測已正確執行順暢…感恩  ^^