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

標題: [發問] 求助~排程填入日期 [打印本頁]

作者: adam2010 時間: 2013-1-10 01:09 標題: 求助~排程填入日期

由於小弟的巨集功力不足，想請教板上各位高手下面這個問題~
想要將出貨日
[attach]13866[/attach]
拆開到各子批的交期
[attach]13867[/attach]
如說明
[attach]13868[/attach]
跪求各位大大協助~謝謝！
[attach]13865[/attach]

作者: dino1978 時間: 2013-1-10 14:18

回復 1# adam2010

試試看吧

Private Sub CommandButton1_Click()
Dim LotID As Range, Tagt As Range, Qty As Range
Dim a, TalQty
With sheet2
For Each LotID In .Range("A2:A" & .[A65536].End(xlUp).Row)
For Each Tagt In .Range("B" & LotID.Row & ":J" & LotID.Row)
If Tagt <> "" Then
With Sheet1
a = Application.Match(LotID, .[A:A], 0)
aa = Application.CountIf(.[A:A], LotID)
TalQty = 0
For Each Qty In .Range("D" & a & ":D" & (a + aa - 1))
If Qty.Offset(, 1) <> "" Then GoTo ntxa
Qty = Qty + TalQty
If Qty < Tagt Then
Qty.Offset(, 1) = sheet2.Cells(1, Tagt.Column)
TalQty = Qty
Else
Qty.Offset(, 1) = sheet2.Cells(1, Tagt.Column)
GoTo ntla
End If
ntxa:
Next Qty
ntla:
End With
End If
Next Tagt
Next LotID
End With
End Sub

複製代碼

作者: adam2010 時間: 2013-1-10 22:10

感謝Dino大大迅速的協助，不過執行後
有部分數量被改到了，跟手動排的也有一些差異(如下圖綠底的部分是手排的結果)
小弟汗顏看不出是哪裡的問題？再次懇請協助，謝謝！
[attach]13873[/attach]

作者: Hsieh 時間: 2013-1-10 22:45

回復 3# adam2010

排程應該會考慮每批最大量或最小量是多少?
就以1/1的250來說，為何要排成2批100、200
不能排100、150嗎?
程式設計必須考慮到整體邏輯相通，若有特別規定就必須詳細說明各種限制條件
才能整理出共同特性來解決問題

作者: adam2010 時間: 2013-1-11 00:20

感謝超級版主的提醒，應該是我描述得不夠清楚...
關於版主所提的問題~排程應該會考慮每批最大量或最小量是多少?
就以1/1的250來說，為何要排成2批100、200，不能排100、150嗎?
因為公司產品特性投料時是外購而來一根一根長短不一的晶棒，批量則是根據切的厚度計算出來的片數，會有上下限但是無法控制批量大小
而且有時候因為機台作業特性(一次要切兩段)，所以可能需求只有250但是投料的時候需要投2段就變成會有多的一批是暫時沒有交期的

因此以這個範例來看只能先將超過1/1需求量的批次A001~A002定交期為1/1，而A002剩下的50片則可以給1/5
然後1/5需要的300片就用A003....一直到最後一批因為前面的數量已經足夠所以就暫時沒有交期
物料B的則一樣因為1/5需求550，所以要有兩個批次才夠
另外就是訂單的出貨日是客戶給的數量以及需求的日期，所以並不會有一定的規則

不知道這樣的描述是不是比較清楚

作者: adam2010 時間: 2013-1-11 00:31

再補充一點就是有時候也會有
有訂單，但是尚未投料的狀況，所以只要將交期分配到同一個物料的批號結束即可

作者: stillfish00 時間: 2013-1-11 14:14

本帖最後由 stillfish00 於 2013-1-11 14:15 編輯

回復 6# adam2010
試試看

Sub Test()
Dim rng As Range
Dim s1 As Long, s2 As Long
Dim cindex As Long
With Sheets(2)
Set rng = .Range(.[A1], .[A1].End(xlToRight).End(xlDown).Offset(, -1)) '[出貨日]資料範圍
End With
For Each c In Sheets(1).[E2:E15] '[交期]資料填入範圍
If c.Offset(, -4).Value <> c.Offset(-1, -4).Value Then
cindex = 1
s1 = 0 '累積至前一批數量
s2 = 0 '累積出貨需求數量
Else
s1 = s1 + c.Offset(-1, -1).Value
End If
Do While s2 <= s1 And cindex < rng.Columns.Count
cindex = cindex + 1
s2 = s2 + Application.VLookup(c.Offset(, -4).Value, rng, cindex, False)
Loop
If s2 <= s1 Then
c.Value = "NA"
Else
c.Value = rng.Cells(1, cindex).Value
End If
Next
Set rng=Nothing
End Sub

複製代碼

作者: adam2010 時間: 2013-1-11 22:44

太感動了!感謝stillfish00大大的協助，這裡真是高手如雲，每個都是大師級的
剛才試了一下完全符合我的需求，不過套用到公司正式的大型檔案發現還有2個小問題
1.For Each c In Sheets(1).[E2:E15] '[交期]資料填入範圍→如果範圍是變動的該如何修改
2.如果遇到交期裡面有但是出貨日沒有的物料就會因為找不到卡在21行→要如何增加一個判別讓找不到的也顯示NA
解決了這2個問題應該就很完美了

作者: Hsieh 時間: 2013-1-12 00:06

本帖最後由 Hsieh 於 2013-1-12 00:10 編輯

回復 8# adam2010
Sheets("交期")的D欄數量是人工先輸入好的嗎?
試試看

Sub ex()
Dim Ar(), Ay(), C As Range, Rng As Range
Set d = CreateObject("Scripting.Dictionary") '數量
Set d1 = CreateObject("Scripting.Dictionary") '日期
With Sheets("出貨日")
For Each a In .Range(.[A2], .[A2].End(xlDown)) '物料
Set Rng = a.EntireRow.SpecialCells(xlCellTypeConstants, xlNumbers) '訂貨
ReDim Preserve Ar(s) '數量
ReDim Preserve Ay(s) '日期
Ar(s) = 0
Ay(s) = .Cells(1, Rng.Column)
s = s + 1
For Each C In Rng
cnt = cnt + C
ReDim Preserve Ar(s)
ReDim Preserve Ay(s)
Ar(s) = cnt
Ay(s) = .Cells(1, C.Column).Value
s = s + 1
Next
d(a.Value) = Ar
d1(a.Value) = Ay
Erase Ar: Erase Ay: s = 0: cnt = 0
Next
End With
With Sheets("交期")
For Each a In .Range(.[A2], .[A2].End(xlDown))
cnt = cnt + a.Offset(, 3)
If cnt <= Application.Max(d(a.Value)) Or cnt - a.Offset(, 3) < Application.Max(d(a.Value)) Then _
a.Offset(, 4) = Application.Lookup(cnt, d(a.Value), d1(a.Value)) _
Else a.Offset(, 4) = "NA"
If a <> a.Offset(1) Then cnt = 0
Next
End With
End Sub

複製代碼

作者: adam2010 時間: 2013-1-12 01:26

Dear Hsieh大~感謝您出手相助
Sheets("交期")的D欄數量是公司報表篩出來的~
用公司的資料測試過之後Hsieh大的巨集解決了找不到會停止的問題，不過日期有些出入
[attach]13886[/attach]
......汗顏找不出問題所在，所以再次求助，謝謝！
[attach]13887[/attach]

作者: stillfish00 時間: 2013-1-12 17:36

回復 8# adam2010

Sub Test()
Dim rng As Range
Dim s1 As Long, s2 As Long
Dim cindex As Long
With Sheets("出貨日")
Set rng = .Range(.[A1], .[A1].End(xlToRight).End(xlDown).Offset(, -1)) '[出貨日]資料範圍
End With
For Each c In Sheets("交期").Range("E2:E" & Sheets("交期").[A1].End(xlDown).Row) '[交期]資料填入範圍
If c.Offset(, -4).Value <> c.Offset(-1, -4).Value Then
cindex = 1
s1 = 0 '累積至前一批數量
s2 = 0 '累積出貨需求數量
Else
s1 = s1 + c.Offset(-1, -1).Value
End If
Do While s2 <= s1
cindex = cindex + 1
If Application.IsError(Application.VLookup(c.Offset(, -4).Value, rng, cindex, False)) Then
Exit Do
Else
s2 = s2 + Application.VLookup(c.Offset(, -4).Value, rng, cindex, False)
End If
Loop
If s2 <= s1 Then
c.Value = "NA"
Else
c.Value = rng.Cells(1, cindex).Value
End If
Next
Set rng = Nothing
End Sub

複製代碼

作者: adam2010 時間: 2013-1-12 18:26

感謝Dino大,Hsieh大以及stillfish00大的協助，
測試無誤，解決我近幾週的困擾，太感動了，謝謝！

作者: Hsieh 時間: 2013-1-12 23:44

回復 10# adam2010
Lookup函數並不適用

Sub ex()
Dim Ar(), Ay(), C As Range, rng As Range
Set d = CreateObject("Scripting.Dictionary") '數量
Set d1 = CreateObject("Scripting.Dictionary") '日期
With Sheets("出貨日")
For Each a In .Range(.[A2], .[A2].End(xlDown)) '物料
Set rng = a.EntireRow.SpecialCells(xlCellTypeConstants, xlNumbers) '應交貨數量
For Each C In rng
cnt = cnt + C
ReDim Preserve Ar(s)
ReDim Preserve Ay(s)
Ar(s) = cnt
Ay(s) = .Cells(1, C.Column).Value
s = s + 1
Next
d(a.Value) = Ar
d1(a.Value) = Ay
Erase Ar: Erase Ay: s = 0: cnt = 0
Next
End With
With Sheets("交期")
For Each a In .Range(.[A2], .[A2].End(xlDown))
cnt = cnt + a.Offset(, 3)
If cnt <= Application.Max(d(a.Value)) Or cnt - a.Offset(, 3) < Application.Max(d(a.Value)) Then
i = 0
Do Until cnt - a.Offset(, 3) < d(a.Value)(i) Or i = UBound(d(a.Value)) '找到陣列中比已交貨數量還大的應交貨數量
n = d(a.Value)(i)
i = i + 1
Loop
a.Offset(, 4) = d1(a.Value)(i)
Else
a.Offset(, 4) = "NA"
End If
If a <> a.Offset(1) Then cnt = 0
Next
End With
End Sub

複製代碼

作者: adam2010 時間: 2013-1-13 22:17

Dear Hsieh大，感謝您的回覆，測試無誤
目前測試您跟stillfish00所提供的均正確，我再研究看看兩者的差異，謝謝！

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