Board logo

標題: [發問] 藉由日期改變計算產品剩餘數量與均價 [打印本頁]
作者: white5168    時間: 2012-5-1 11:09     標題: 藉由日期改變計算產品剩餘數量與均價

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

本帖最後由 register313 於 2012-5-1 13:03 編輯

回復 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
複製代碼
[attach]10768[/attach]
作者: white5168    時間: 2012-5-1 13:58

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



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