[發問] 求助~排程填入日期

adam2010

由於小弟的巨集功力不足，想請教板上各位高手下面這個問題~
想要將出貨日

下載 (23.88 KB)
出貨日

2013-1-10 01:04

拆開到各子批的交期

下載 (49.54 KB)
交期

2013-1-10 01:04

如說明

下載 (113.32 KB)
說明

2013-1-10 01:04

跪求各位大大協助~謝謝！
排程問題.rar (4.82 KB)

檔案
下載次數: 21

2013-1-10 00:56

adam2010

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

Hsieh

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

1. Sub ex()
   
2. Dim Ar(), Ay(), C As Range, rng As Range
   
3. Set d = CreateObject("Scripting.Dictionary") '數量
   
4. Set d1 = CreateObject("Scripting.Dictionary") '日期
   
5. With Sheets("出貨日")
   
6. For Each a In .Range(.[A2], .[A2].End(xlDown)) '物料
   
7.   Set rng = a.EntireRow.SpecialCells(xlCellTypeConstants, xlNumbers) '應交貨數量
   
8.      For Each C In rng
   
9.         cnt = cnt + C
   
10.         ReDim Preserve Ar(s)
    
11.         ReDim Preserve Ay(s)
    
12.         Ar(s) = cnt
    
13.         Ay(s) = .Cells(1, C.Column).Value
    
14.         s = s + 1
    
15.      Next
    
16.      d(a.Value) = Ar
    
17.      d1(a.Value) = Ay
    
18.      Erase Ar: Erase Ay: s = 0: cnt = 0
    
19. Next
    
20. End With
    
21. With Sheets("交期")
    
22.   For Each a In .Range(.[A2], .[A2].End(xlDown))
    
23.      cnt = cnt + a.Offset(, 3)
    
24.      If cnt <= Application.Max(d(a.Value)) Or cnt - a.Offset(, 3) < Application.Max(d(a.Value)) Then
    
25.      i = 0
    
26.      Do Until cnt - a.Offset(, 3) < d(a.Value)(i) Or i = UBound(d(a.Value))  '找到陣列中比已交貨數量還大的應交貨數量
    
27.      n = d(a.Value)(i)
    
28.        i = i + 1
    
29.      Loop
    
30.      a.Offset(, 4) = d1(a.Value)(i)
    
31.      Else
    
32.      a.Offset(, 4) = "NA"
    
33.      End If
    
34.      If a <> a.Offset(1) Then cnt = 0
    
35.   Next
    
36. End With
    
37. End Sub

複製代碼

adam2010

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

stillfish00

回復 8# adam2010

1. Sub Test()
   
2. Dim rng As Range
   
3. Dim s1 As Long, s2 As Long
   
4. Dim cindex As Long
   
5. 
   
6. With Sheets("出貨日")
   
7.     Set rng = .Range(.[A1], .[A1].End(xlToRight).End(xlDown).Offset(, -1))  '[出貨日]資料範圍
   
8. End With
   
9. 
   
10. For Each c In Sheets("交期").Range("E2:E" & Sheets("交期").[A1].End(xlDown).Row)   '[交期]資料填入範圍
    
11.     If c.Offset(, -4).Value <> c.Offset(-1, -4).Value Then
    
12.         cindex = 1
    
13.         s1 = 0  '累積至前一批數量
    
14.         s2 = 0  '累積出貨需求數量
    
15.     Else
    
16.         s1 = s1 + c.Offset(-1, -1).Value
    
17.     End If
    
18.    
    
19.     Do While s2 <= s1
    
20.         cindex = cindex + 1
    
21.         If Application.IsError(Application.VLookup(c.Offset(, -4).Value, rng, cindex, False)) Then
    
22.             Exit Do
    
23.         Else
    
24.             s2 = s2 + Application.VLookup(c.Offset(, -4).Value, rng, cindex, False)
    
25.         End If
    
26.     Loop
    
27.    
    
28.     If s2 <= s1 Then
    
29.         c.Value = "NA"
    
30.     Else
    
31.         c.Value = rng.Cells(1, cindex).Value
    
32.     End If
    
33. Next
    
34. Set rng = Nothing
    
35. End Sub

複製代碼

adam2010

Dear Hsieh大~感謝您出手相助
Sheets("交期")的D欄數量是公司報表篩出來的~
用公司的資料測試過之後Hsieh大的巨集解決了找不到會停止的問題，不過日期有些出入

下載 (131.85 KB)

2013-1-12 01:23

......汗顏找不出問題所在，所以再次求助，謝謝！
Test-1.rar (31.57 KB)

下載次數: 14

2013-1-12 01:23

Hsieh

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

1. Sub ex()
   
2. Dim Ar(), Ay(), C As Range, Rng As Range
   
3. Set d = CreateObject("Scripting.Dictionary") '數量
   
4. Set d1 = CreateObject("Scripting.Dictionary") '日期
   
5. With Sheets("出貨日")
   
6. For Each a In .Range(.[A2], .[A2].End(xlDown)) '物料
   
7.   Set Rng = a.EntireRow.SpecialCells(xlCellTypeConstants, xlNumbers) '訂貨
   
8.   ReDim Preserve Ar(s) '數量
   
9.   ReDim Preserve Ay(s) '日期
   
10.   Ar(s) = 0
    
11.   Ay(s) = .Cells(1, Rng.Column)
    
12.   s = s + 1
    
13.      For Each C In Rng
    
14.         cnt = cnt + C
    
15.         ReDim Preserve Ar(s)
    
16.         ReDim Preserve Ay(s)
    
17.         Ar(s) = cnt
    
18.         Ay(s) = .Cells(1, C.Column).Value
    
19.         s = s + 1
    
20.      Next
    
21.      d(a.Value) = Ar
    
22.      d1(a.Value) = Ay
    
23.      Erase Ar: Erase Ay: s = 0: cnt = 0
    
24. Next
    
25. End With
    
26. With Sheets("交期")
    
27.   For Each a In .Range(.[A2], .[A2].End(xlDown))
    
28.      cnt = cnt + a.Offset(, 3)
    
29.      If cnt <= Application.Max(d(a.Value)) Or cnt - a.Offset(, 3) < Application.Max(d(a.Value)) Then _
    
30.      a.Offset(, 4) = Application.Lookup(cnt, d(a.Value), d1(a.Value)) _
    
31.      Else a.Offset(, 4) = "NA"
    
32.      If a <> a.Offset(1) Then cnt = 0
    
33.   Next
    
34. End With
    
35. End Sub

複製代碼

adam2010

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

stillfish00

回復 6# adam2010
試試看

1. Sub Test()
   
2. Dim rng As Range
   
3. Dim s1 As Long, s2 As Long
   
4. Dim cindex As Long
   
5. 
   
6. With Sheets(2)
   
7.     Set rng = .Range(.[A1], .[A1].End(xlToRight).End(xlDown).Offset(, -1))  '[出貨日]資料範圍
   
8. End With
   
9. 
   
10. For Each c In Sheets(1).[E2:E15]    '[交期]資料填入範圍
    
11.     If c.Offset(, -4).Value <> c.Offset(-1, -4).Value Then
    
12.         cindex = 1
    
13.         s1 = 0  '累積至前一批數量
    
14.         s2 = 0  '累積出貨需求數量
    
15.     Else
    
16.         s1 = s1 + c.Offset(-1, -1).Value
    
17.     End If
    
18.    
    
19.     Do While s2 <= s1 And cindex < rng.Columns.Count
    
20.         cindex = cindex + 1
    
21.         s2 = s2 + Application.VLookup(c.Offset(, -4).Value, rng, cindex, False)
    
22.     Loop
    
23.    
    
24.     If s2 <= s1 Then
    
25.         c.Value = "NA"
    
26.     Else
    
27.         c.Value = rng.Cells(1, cindex).Value
    
28.     End If
    
29. Next
    
30. Set rng=Nothing
    
31. End Sub

複製代碼

adam2010

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