麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 兩種不同條件的運費計算如何合併 [打印本頁]

作者: dou10801 時間: 2022-5-20 14:58 標題: 兩種不同條件的運費計算如何合併

兩種不同條件的運費計算如何合併,懇請前輩指點,感恩.

作者: dou10801 時間: 2022-5-20 16:30

本帖最後由 dou10801 於 2022-5-20 16:33 編輯

回復 1# dou10801 更正[張三]合計運費,位置放錯,抱歉.

作者: hcm19522 時間: 2022-5-20 17:27

本帖最後由 hcm19522 於 2022-5-21 10:05 編輯

https://blog.xuite.net/hcm19522/twblog/590390712

作者: singo1232001 時間: 2022-5-20 18:06

回復 2# dou10801

作者: dou10801 時間: 2022-5-27 14:41

感謝:hcm19522和singo1232001先進,收下學習,感恩.

作者: samwang 時間: 2022-5-27 21:04

回復 2# dou10801

請測試看看，謝謝

作者: samwang 時間: 2022-5-27 21:15

本帖最後由 samwang 於 2022-5-27 21:16 編輯

回復 4# singo1232001

Singo1232001您好，
剛剛測試了一下您的程式，新增人數會有問題如圖片，另外合計運費也是有點問題
請再確認，謝謝

作者: singo1232001 時間: 2022-5-28 08:04

回復 7# samwang

Sub test()

Set d = CreateObject("scripting.dictionary")
Set d0 = CreateObject("scripting.dictionary")
  Set d1 = CreateObject("scripting.dictionary")
  rw = Cells(Rows.Count, 1).End(3).Row
ar = Range("a2:G" & rw)
[N:R].ClearContents

For i = 1 To UBound(ar)
ar(i, 6) = "": ar(i, 7) = ""
If ar(i, 4) <= 10 Then ar(i, 6) = 0: ar(i, 7) = ar(i, 3) * 15
If ar(i, 4) > 10 Then ar(i, 6) = 1: ar(i, 7) = ar(i, 5) * 2
If d.exists(ar(i, 1)) = False Then Set d(ar(i, 1)) = CreateObject("scripting.dictionary")
   d(ar(i, 1))("件") = d(ar(i, 1))("件") + ar(i, 3)
   d(ar(i, 1))("重") = d(ar(i, 1))("重") + ar(i, 5)
   d(ar(i, 1))("費") = d(ar(i, 1))("費") + ar(i, 7)
d0(ar(i, 1)) = d0.Count
   d1(ar(i, 2)) = d1.Count
Next

ReDim br(0 To d.Count - 1, 1 To 4)
For i = 0 To d.Count - 1
br(i, 1) = d.keys()(i)
br(i, 2) = d(br(i, 1))("件")
  br(i, 3) = d(br(i, 1))("重")
br(i, 4) = d(br(i, 1))("費")
Next

Set Rng = [N1]
Rng.Resize(1, 4) = Array("出貨人", "總件數", "總重量", "合計運費")
  Rng.Offset(1, 0).Resize(UBound(br) + 1, 4) = br

ReDim cr(1 To d.Count)  '建陣列 3+2維
ReDim dr(1 To d1.Count * d.Count)
  ReDim er(0 To 1) '
ReDim fr(0 To 1000, 0 To 5)
For i = 1 To UBound(cr)
   cr(i) = dr
   For j = 1 To UBound(cr(i))
      cr(i)(j) = er
      For k = 0 To 1
      cr(i)(j)(k) = fr
      cr(i)(j)(k)(0, 0) = 0
      Next
   Next
Next

For i = 1 To UBound(ar) '放資料
i0 = d0(ar(i, 1)) '姓名
  j = d1(ar(i, 2)) '水果
k = ar(i, 6)    '0小於10公斤 1大於10公斤
cr(i0)(j)(k)(0, 0) = cr(i0)(j)(k)(0, 0) + 1
w = cr(i0)(j)(k)(0, 0)
cr(i0)(j)(k)(w, 1) = ar(i, 1)
cr(i0)(j)(k)(w, 2) = ar(i, 2)
  cr(i0)(j)(k)(w, 3) = ar(i, 3)
cr(i0)(j)(k)(w, 4) = ar(i, 4)
cr(i0)(j)(k)(w, 5) = ar(i, 5)
Next

For i = 1 To UBound(cr) '資料貼工作表
For j = 1 To UBound(cr(i))
  For k = 0 To 1
r0 = Cells(Rows.Count, Rng.Column + 1).End(3).Row + 2
If cr(i)(j)(k)(0, 0) <> 0 Then
      a3 = 0: a4 = 0: a5 = 0
      For L = 1 To cr(i)(j)(k)(0, 0)
      a3 = a3 + cr(i)(j)(k)(L, 3)
      a4 = a4 + cr(i)(j)(k)(L, 4)
      a5 = a5 + cr(i)(j)(k)(L, 5)
      Next
      Cells(r0, Rng.Column - 1).Resize(cr(i)(j)(k)(0, 0) + 1, 6) = cr(i)(j)(k)
      Cells(r0, Rng.Column - 1).Resize(1, 6) = Array(Cells(r0, Rng.Column), "出貨人", "品名", "件數", "件重/ kg", "總重量")
      Cells(Cells(Rows.Count, "Q").End(3).Row + 1, "M").Resize(1, 6) = Array("", "", "", a3, a4, a5)
End If
  Next
Next
Next

End Sub

作者: dou10801 時間: 2022-5-31 11:35

回復 7# samwang 感謝samwang先進,是我需求數字,感恩.

作者: Andy2483 時間: 2023-11-29 14:28

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

執行結果:
[attach]37078[/attach]

Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 1000, 1 To 5), T(2 To 4), Z, P, A, Q&, i&, R&, N&, F&, j%, x%, B$, T0$, T1$
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range([E2], [A65536].End(xlUp))
P = [{"出貨人","品名","件數","件重/ kg","總重量"}]
For i = 1 To UBound(Brr)
If Z(Brr(i, 1) & "") = "" Then F = F + 1: Z(Brr(i, 1) & "") = F + 1: Z(F + 1) = Brr(i, 1)
B = IIf(Brr(i, 4) >= 10, Brr(i, 1) & "/重計", Brr(i, 1) & "/件計")
Q = Z(B & Brr(i, 2) & "/" & Brr(i, 4))
A = Z(B): R = Z(B & "\r")
If Not IsArray(A) Then A = Crr: R = R + 1: For j = 1 To 5: A(R, j) = P(j): Next
If Q = 0 Then
   R = R + 1: A(R, 1) = Brr(i, 1): A(R, 2) = Brr(i, 2): A(R, 4) = Brr(i, 4)
   Q = R: Z(B & Brr(i, 2) & "/" & Brr(i, 4)) = Q
End If
A(Q, 3) = A(Q, 3) + Val(Brr(i, 3))
Z(B) = A: Z(B & "\r") = R
Next
[N:R].Clear: N = F + 2
With [N1].Resize(F + 1, 4)
.Rows(1) = [{"出貨人","總件數","總重量","合計運費"}]
.Borders.LineStyle = xlContinuous
.Font.Bold = True
.Font.ColorIndex = 5
For i = 2 To F + 1: [N1].Item(i, 1) = Z(i): Next
End With
For Each A In Z.Keys
If Not IsArray(Z(A)) Then GoTo A01 Else R = Z(A & "\r")
T0 = Split(A, "/")(0): T1 = Split(A, "/")(1)
With [N1].Item(N + 1).Resize(Z(A & "\r") + 1, 5)
   .Value = Z(A): .Cells(R + 1, 1) = "運費合計"
   .Cells(2, 5).Resize(R - 1) = "=" & .Cells(2, 3).Address(0, 0) & "*" & .Cells(2, 4).Address(0, 0)
   T(2) = "=SUM(P" & N + 2 & ":P" & N + R & ")"
   T(3) = "=SUM(R" & N + 2 & ":R" & N + R & ")"
   If T1 = "件計" Then
      .Cells(R + 1, 4) = "以件計"
      .Cells(R + 1, 3) = T(2)
      T(4) = "=" & .Cells(R + 1, 3).Address(0, 0) & "*15"
      .Cells(R + 1, 2) = Evaluate(T(4))
      Else
         .Cells(R + 1, 4) = "以重計"
         .Cells(R + 1, 5) = T(3)
         T(4) = "=" & .Cells(R + 1, 5).Address(0, 0) & "*2"
         .Cells(R + 1, 2) = Evaluate(T(4))
   End If
   .Cells(R + 1, 1).Resize(, 2).Font.Bold = True
   .Cells(R + 1, 1).Resize(, 5).Font.ColorIndex = 5
   .Cells.Borders.LineStyle = xlContinuous
   .Cells.Interior.ColorIndex = 24 + (T1 = "件計") * 4
End With
For j = 2 To 4: [N1].Item(Z(T0), j) = [N1].Item(Z(T0), j) + Evaluate(T(j)): Next
N = N + R + 1
A01: Next
End Sub

作者: hcm19522 時間: 2023-11-29 16:02

(輸入編號12076) google網址:https://hcm19522.blogspot.com/

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