- 帖子
- 967
- 主題
- 0
- 精華
- 0
- 積分
- 1001
- 點名
- 0
- 作業系統
- WIN XP
- 軟體版本
- OFFICE 2003
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台北
- 註冊時間
- 2010-11-29
- 最後登錄
- 2022-5-17
 
|
2#
發表於 2012-5-1 13:00
| 只看該作者
本帖最後由 register313 於 2012-5-1 13:03 編輯
回復 1# white5168
參考用,語法不理想,執行速度慢
自動結算到購買日期之最後一日
SOURCE工作表會被排序- Sub AA()
- Dim Er(), Fr()
- Set d = CreateObject("scripting.dictionary")
- Set d1 = CreateObject("scripting.dictionary")
- Set d2 = CreateObject("scripting.dictionary")
- Set d3 = CreateObject("scripting.dictionary")
- With Sheets("Source")
- M = .[B2].End(xlDown).Row
- .[A1].CurrentRegion.Sort Key1:=.[A2], Order1:=xlAscending, Header:=xlGuess
- .[A1].CurrentRegion.Sort Key1:=.[B2], Order1:=xlAscending, Header:=xlGuess
- Br = .Range("A2:E" & .[B2].End(xlDown).Row)
- For i = 1 To UBound(Br)
- x = Br(i, 2)
- d(x) = d(x) + 1
- If Not d1.exists(x) Then d1.Add x, Br(i, 4) Else d1(x) = d1(x) + Br(i, 4)
- If Not d2.exists(x) Then d2.Add x, Br(i, 5) Else d2(x) = d2(x) + Br(i, 5)
- If Not d3.exists(x) Then d3.Add x, Br(i, 3) * (Br(i, 5) - Br(i, 4)) Else d3(x) = d3(x) + Br(i, 3) * (Br(i, 5) - Br(i, 4))
- Next i
- End With
- With Sheets("最後資料")
- .[B1] = Application.Max(Sheets("Source").Columns("A"))
- .[A3].CurrentRegion.Offset(1, 0) = ""
- .[A4].Resize(d.Count, 1) = Application.Transpose(d.keys)
- .[B4].Resize(d.Count, 1) = Application.Transpose(d1.Items)
- .[C4].Resize(d.Count, 1) = Application.Transpose(d2.Items)
- .[D4].Resize(d.Count, 1) = Application.Transpose(d3.Items)
- For R = 4 To d.Count + 3
- ReDim Preserve Er(4 To R)
- ReDim Preserve Fr(4 To R)
- If .Cells(R, "B") >= .Cells(R, "C") Then
- Er(R) = .Cells(R, "B") - .Cells(R, "C")
- Else
- Fr(R) = .Cells(R, "B") - .Cells(R, "C")
- End If
- Next R
- .[E4].Resize(R - 4, 1) = Application.Transpose(Er)
- .[F4].Resize(R - 4, 1) = Application.Transpose(Fr)
- For R = 4 To d.Count + 3
- If .Cells(R, "E") > 0 Then
- Max = Application.Match(.Cells(R, "A"), Sheets("Source").Range(Sheets("Source").[B1], Sheets("Source").[B1].End(xlDown)), 0) + d(.Cells(R, "A").Value) - 1
- Min = Max - d(.Cells(R, "A").Value) + 1
- 總額 = 0: 剩餘總數 = 0
- 剩餘數量 = .Cells(R, "E")
- For S = Max To Min Step -1
- If 剩餘數量 > Sheets("Source").Cells(S, "D") Then
- 總額 = 總額 + Sheets("Source").Cells(S, "C") * Sheets("Source").Cells(S, "D")
- 剩餘數量 = 剩餘數量 - Sheets("Source").Cells(S, "D")
- 剩餘總數1 = 剩餘總數1 + Sheets("Source").Cells(S, "D")
- Else
- 總額 = 總額 + Sheets("Source").Cells(S, "C") * 剩餘數量
- .Cells(R, "G") = 總額 / .Cells(R, "E")
- .Cells(R, "D") = .Cells(R, "D") + 總額 * 2
- GoTo 123
- End If
- Next S
- End If
- 123:
- Next R
- For R = 4 To d.Count + 3
- If .Cells(R, "F") < 0 Then
- Max = Application.Match(.Cells(R, "A"), Sheets("Source").Range(Sheets("Source").[B1], Sheets("Source").[B1].End(xlDown)), 0) + d(.Cells(R, "A").Value) - 1
- Min = Max - d(.Cells(R, "A").Value) + 1
- 總額 = 0: 剩餘總數 = 0
- 剩餘數量 = -.Cells(R, "F")
- For S = Max To Min Step -1
- If 剩餘數量 > Sheets("Source").Cells(S, "E") Then
- 總額 = 總額 + Sheets("Source").Cells(S, "C") * Sheets("Source").Cells(S, "E")
- 剩餘數量 = 剩餘數量 - Sheets("Source").Cells(S, "E")
- 剩餘總數1 = 剩餘總數1 + Sheets("Source").Cells(S, "E")
- Else
- 總額 = 總額 + Sheets("Source").Cells(S, "C") * 剩餘數量
- .Cells(R, "H") = 總額 / -.Cells(R, "F")
- GoTo 456
- End If
- Next S
- End If
- 456:
- Next R
- .Range("G4:H" & d.Count + 3).NumberFormatLocal = "0.00"
- End With
- MsgBox "結算完畢"
- End Sub
 test.rar (14.91 KB)
|
|
