[發問] 藉由日期改變計算產品剩餘數量與均價

white5168

小弟才疏學淺需要一個能藉由日期改變計算產品剩餘數量與均價的excel,請各位大大幫幫忙
如圖分別為資料與最後畫面
最後畫面的部份對於日期是可調整的,如日期變動,則最後資料所呈現的畫面也會改變
相關的Excel檔在附件中,如有不清楚的請再提出發問
原始資料與所需資料都在附件裡

white5168

請問register313 大大能將程式碼模組化嗎?
還有目前我還無法下載您所提供的壓縮檔,請問您貼在網頁上的程式碼是附件裡的內容嗎?

register313

回復 1# white5168

參考用,語法不理想,執行速度慢
自動結算到購買日期之最後一日
SOURCE工作表會被排序

1. Sub AA()
   
2. Dim Er(), Fr()
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d1 = CreateObject("scripting.dictionary")
   
5. Set d2 = CreateObject("scripting.dictionary")
   
6. Set d3 = CreateObject("scripting.dictionary")
   
7. With Sheets("Source")
   
8.   M = .[B2].End(xlDown).Row
   
9.   .[A1].CurrentRegion.Sort Key1:=.[A2], Order1:=xlAscending, Header:=xlGuess
   
10.   .[A1].CurrentRegion.Sort Key1:=.[B2], Order1:=xlAscending, Header:=xlGuess
    
11.   Br = .Range("A2:E" & .[B2].End(xlDown).Row)
    
12.   For i = 1 To UBound(Br)
    
13.     x = Br(i, 2)
    
14.     d(x) = d(x) + 1
    
15.     If Not d1.exists(x) Then d1.Add x, Br(i, 4) Else d1(x) = d1(x) + Br(i, 4)
    
16.     If Not d2.exists(x) Then d2.Add x, Br(i, 5) Else d2(x) = d2(x) + Br(i, 5)
    
17.     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))
    
18.   Next i
    
19. End With
    
20. With Sheets("最後資料")
    
21.   .[B1] = Application.Max(Sheets("Source").Columns("A"))
    
22.   .[A3].CurrentRegion.Offset(1, 0) = ""
    
23.   .[A4].Resize(d.Count, 1) = Application.Transpose(d.keys)
    
24.   .[B4].Resize(d.Count, 1) = Application.Transpose(d1.Items)
    
25.   .[C4].Resize(d.Count, 1) = Application.Transpose(d2.Items)
    
26.   .[D4].Resize(d.Count, 1) = Application.Transpose(d3.Items)
    
27.   For R = 4 To d.Count + 3
    
28.     ReDim Preserve Er(4 To R)
    
29.     ReDim Preserve Fr(4 To R)
    
30.     If .Cells(R, "B") >= .Cells(R, "C") Then
    
31.        Er(R) = .Cells(R, "B") - .Cells(R, "C")
    
32.     Else
    
33.        Fr(R) = .Cells(R, "B") - .Cells(R, "C")
    
34.     End If
    
35.   Next R
    
36.   .[E4].Resize(R - 4, 1) = Application.Transpose(Er)
    
37.   .[F4].Resize(R - 4, 1) = Application.Transpose(Fr)
    
38.   For R = 4 To d.Count + 3
    
39.     If .Cells(R, "E") > 0 Then
    
40.        Max = Application.Match(.Cells(R, "A"), Sheets("Source").Range(Sheets("Source").[B1], Sheets("Source").[B1].End(xlDown)), 0) + d(.Cells(R, "A").Value) - 1
    
41.        Min = Max - d(.Cells(R, "A").Value) + 1
    
42.        總額 = 0: 剩餘總數 = 0
    
43.        剩餘數量 = .Cells(R, "E")
    
44.        For S = Max To Min Step -1
    
45.          If 剩餘數量 > Sheets("Source").Cells(S, "D") Then
    
46.             總額 = 總額 + Sheets("Source").Cells(S, "C") * Sheets("Source").Cells(S, "D")
    
47.             剩餘數量 = 剩餘數量 - Sheets("Source").Cells(S, "D")
    
48.             剩餘總數1 = 剩餘總數1 + Sheets("Source").Cells(S, "D")
    
49.          Else
    
50.             總額 = 總額 + Sheets("Source").Cells(S, "C") * 剩餘數量
    
51.             .Cells(R, "G") = 總額 / .Cells(R, "E")
    
52.             .Cells(R, "D") = .Cells(R, "D") + 總額 * 2
    
53.             GoTo 123
    
54.          End If
    
55.        Next S
    
56.      End If
    
57. 123:
    
58.   Next R
    
59.   For R = 4 To d.Count + 3
    
60.     If .Cells(R, "F") < 0 Then
    
61.        Max = Application.Match(.Cells(R, "A"), Sheets("Source").Range(Sheets("Source").[B1], Sheets("Source").[B1].End(xlDown)), 0) + d(.Cells(R, "A").Value) - 1
    
62.        Min = Max - d(.Cells(R, "A").Value) + 1
    
63.        總額 = 0: 剩餘總數 = 0
    
64.        剩餘數量 = -.Cells(R, "F")
    
65.        For S = Max To Min Step -1
    
66.          If 剩餘數量 > Sheets("Source").Cells(S, "E") Then
    
67.             總額 = 總額 + Sheets("Source").Cells(S, "C") * Sheets("Source").Cells(S, "E")
    
68.             剩餘數量 = 剩餘數量 - Sheets("Source").Cells(S, "E")
    
69.             剩餘總數1 = 剩餘總數1 + Sheets("Source").Cells(S, "E")
    
70.          Else
    
71.             總額 = 總額 + Sheets("Source").Cells(S, "C") * 剩餘數量
    
72.             .Cells(R, "H") = 總額 / -.Cells(R, "F")
    
73.             GoTo 456
    
74.          End If
    
75.        Next S
    
76.      End If
    
77. 456:
    
78.   Next R
    
79.   .Range("G4:H" & d.Count + 3).NumberFormatLocal = "0.00"
    
80. End With
    
81. MsgBox "結算完畢"
    
82. End Sub

複製代碼

test.rar (14.91 KB)

下載次數: 9

2012-5-1 13:03