Board logo

標題: 依訂單資料轉換成六週排程表，敬請各位大大賜教!!! [打印本頁]
作者: p6703    時間: 2012-4-24 23:36     標題: 依來源資料比對符合日期套取在對應的欄位上???

如附件每日會有資料填於Sheet上，可否使用VBA將資料套取於Sheet2上的表格格式，懇請各位高手教導，在此先謝謝:)

主要依"交期"欄位會有分多筆，於需求日需加總同訂單數，而交期欄位各別比對其對應的符合日期欄位

[attach]10644[/attach]
作者: register313    時間: 2012-4-25 00:02

回復 1# p6703


看不懂如何對應? 如何填入sheet2?
給個範例 填入excel表內 較易了解
作者: c_c_lai    時間: 2012-4-25 06:44

回復 2# register313
他的意思應該是：
[attach]10649[/attach]
作者: p6703    時間: 2012-4-25 09:17

感謝c_c_lai 兄的補充說明，的確此就是小弟所想要的功能

但再額外補充說明一下,就如符件中的Sheet1上的訂單資料，其實有三筆是重覆的（因交期因素把它拆開來），但套到Sheet2時要匯整成一項（需求數加總，並依交期數分別套在對應的日期上）
作者: register313    時間: 2012-4-25 18:12

回復 4# p6703

程式語法不理想,尚有改進空間,請指正
  1. Sub zz()
  2. Set d = CreateObject("scripting.dictionary")
  3. With Sheet1
  4.   ar = .Range("A2:F" & .[F2].End(xlDown).Row)
  5.   For i = 1 To UBound(ar)
  6.     x = ar(i, 1) & "," & ar(i, 2) & "," & ar(i, 3)
  7.     If Not d.exists(x) Then d.Add x, ar(i, 4) Else d(x) = d(x) + ar(i, 4)
  8.   Next i
  9. End With
  10. a = d.keys: b = d.items
  11. c = 0
  12. With Sheet2
  13.   .[A1].CurrentRegion.Offset(1, 0) = ""
  14.   For i = 0 To d.Count - 1
  15.     y = Split(a(i), ",")
  16.     .Range("A2").Offset(c, 0).Resize(1, 3) = y
  17.     .Range("D2").Offset(c, 0).Resize(2, 1) = Application.Transpose(Array("需求日", "交期"))
  18.     For j = 2 To Sheet1.[A2].End(xlDown).Row
  19.       x = Sheet1.Cells(j, 1) & "," & Sheet1.Cells(j, 2) & "," & Sheet1.Cells(j, 3)
  20.       If a(i) = x Then
  21.         E = Application.Match(Sheet1.Cells(j, 5), .Range(.[E1], .[E1].End(xlToRight)), 0)
  22.         .Range("E2").Offset(c, E - 1) = d(x)
  23.         F = Application.Match(Sheet1.Cells(j, 6), .Range(.[E1], .[E1].End(xlToRight)), 0)
  24.         .Range("E3").Offset(c, F - 1) = Sheet1.Cells(j, 4)
  25.       End If
  26.     Next j
  27.     c = c + 2
  28.   Next i
  29. End With
  30. End Sub
複製代碼
作者: p6703    時間: 2012-4-25 21:49

感謝register313兄指教，但小弟將程式碼複製執行巨集時，卻跑出"執行階段錯誤 '424': 此處需要物件"的警告視窗，停在.[A1].CurrentRegion.Offset(1, 0) = ""此列，不知何故???
作者: register313    時間: 2012-4-25 21:54

回復 6# p6703
作者: p6703    時間: 2012-4-25 22:27

感謝register313兄，可以執行了，但小弟不明白，程式碼一樣，因何小弟自己複製貼上的就不行呢???還有小弟接觸vba不久，不知是否可請register313兄針對程式碼小小說明一下，謝謝...
作者: p6703    時間: 2012-4-27 23:18

小弟先摸索看看了.再次感謝register313兄^^
作者: Hsieh    時間: 2012-4-27 23:59

本帖最後由 Hsieh 於 2012-4-28 00:11 編輯

回復 4# p6703
  1. Sub Ex()
  2. Dim A As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With Sheet2
  5. n = .Cells(1, .Columns.Count).End(xlToLeft).Column - 1
  6. s = Day(.[E1])
  7. With Sheet1
  8.    For Each A In .Range(.[A2], .[A2].End(xlDown))
  9. ReDim ar(0 To 1, 0 To n)
  10.        m = A & "," & A.Offset(, 1) & "," & A.Offset(, 2)
  11.        If IsEmpty(d(m)) Then
  12.        GoTo 10
  13.        Else
  14.        For i = 0 To 1
  15.          For j = 0 To n
  16.            ar(i, j) = d(m)(i, j)
  17.          Next
  18.        Next
  19.        End If
  20. 10
  21.        x = Day(A.Offset(, 4)) - s + 4 '需求日
  22.        y = Day(A.Offset(, 5)) - s + 4 '交期
  23.        For i = 0 To 2
  24.          ar(0, i) = A.Offset(, i)
  25.        Next
  26.        ar(0, 3) = "需求日"
  27.        ar(1, 3) = "交期"
  28.        ar(0, x) = ar(0, x) + A.Offset(, 3) '需求
  29.        ar(1, y) = A.Offset(, 3)
  30.        d(m) = ar
  31.        Erase ar
  32.    Next
  33. End With
  34. r = 2
  35. For Each ky In d.keys
  36.   .Cells(r, 1).Resize(2, n + 1) = d(ky)
  37.   r = r + 2
  38. Next
  39. End With
  40. End Sub
複製代碼
作者: p6703    時間: 2012-4-29 12:43

感謝Hsieh 版主，小弟將代碼複製要執行時，又在"n = .Cells(1, .Columns.Count).End(xlToLeft).Column - 1”此列跑出"執行階段錯誤 '424': 此處需要物件"的警告視窗，是除了複製外還有需要再做什麼的設定嗎???
作者: p6703    時間: 2012-5-2 17:26

Hsieh 版主因小弟實際排程有時會有跨月的問題，例：需求日5/20，交期回覆到6/10，但按目前巨集執行發現僅比對"日"而已，如按以上日期，其交期對應的會秀到5/10，此是否可再修正???
作者: Hsieh    時間: 2012-5-2 18:33

回復 12# p6703
  1. Sub Ex()
  2. Dim A As Range, x%, y%
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With Sheets("Sheet2")
  5. s = Application.Min(.Rows(1))
  6. With Sheets("Sheet1")
  7. n = Application.Max(.Columns("E:F")) - s + 4
  8.    For Each A In .Range(.[A2], .[A2].End(xlDown))
  9. ReDim ar(0 To 1, 0 To n)
  10.        m = A & "," & A.Offset(, 1) & "," & A.Offset(, 2)
  11.        If IsEmpty(d(m)) Then
  12.        GoTo 10
  13.        Else
  14.        For i = 0 To 1
  15.          For j = 0 To n
  16.            ar(i, j) = d(m)(i, j)
  17.          Next
  18.        Next
  19.        End If
  20. 10
  21.        x = A.Offset(, 4) - s + 4 '需求日
  22.        y = A.Offset(, 5) - s + 4 '交期
  23.        For i = 0 To 2
  24.          ar(0, i) = A.Offset(, i)
  25.        Next
  26.        ar(0, 3) = "需求日"
  27.        ar(1, 3) = "交期"
  28.        ar(0, x) = ar(0, x) + A.Offset(, 3) '需求
  29.        ar(1, y) = A.Offset(, 3)
  30.        d(m) = ar
  31.        Erase ar
  32.    Next
  33. End With
  34. r = 2
  35. For Each ky In d.keys
  36.   .Cells(r, 1).Resize(2, n + 1) = d(ky)
  37.   r = r + 2
  38. Next
  39. End With
  40. End Sub
複製代碼
作者: p6703    時間: 2012-5-2 22:22

先感謝Hsieh版主了,明日再測試看看,但上一個問題仍想請問,就是如單複製代碼,因何執行巨集會跑出錯誤呢...
Hsieh版主的巨集,大大降低工作量,真的太感謝你了
作者: Hsieh    時間: 2012-5-2 22:33

本帖最後由 Hsieh 於 2012-5-2 22:35 編輯

回復 14# p6703

如果以2010版本開啟檔案時，因為工作表的codename是"工作表1"、"工作表2"...等，並非"Sheet1"、"Sheet2"...等
所以出錯。
請檢查工作表的CodeName是否存在?

最後的發帖中已經改成使用工作表的Name屬性，若有錯誤請檢查工作表名稱。

[attach]10787[/attach]
作者: p6703    時間: 2012-5-3 08:43

感謝Hsieh兄的回覆,小弟按最新程式碼執行後,卻跑出"執行階段錯誤'9'，陣列索引超出範圍"，並停在ar(0, x) = ar(0, x) + A.Offset(, 3)此程式碼，因我現執行的筆數有快200筆，是有設限筆數嗎???

還有原提供報表中僅有"訂單＂，"料號"，"項次"三資料，但如果要再增加幾筆資料，原程式碼是否即需再修改???
作者: Hsieh    時間: 2012-5-3 14:20

回復 16# p6703

我猜想是你的Sheet2!E2的日期比所有訂單日期的最小值還大，才會產生這樣結果
請上傳出錯檔案才能知道確實原因
作者: p6703    時間: 2012-5-3 19:14

的確有如Hsieh版主所說的狀況，但即使我將日期最小值已更新至5/1起，但執行時仍發生錯誤，附上檔案，煩請Hsieh版主解惑，謝謝!!!
[attach]10792[/attach]
作者: Hsieh    時間: 2012-5-3 19:32

回復 18# p6703
  1. Sub Ex()
  2. Dim A As Range, x#, y#
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With Sheets("Sheet2")
  5. s = Application.Min(.Rows(1))
  6. With Sheets("Sheet1")
  7. n = Application.Max(.Columns("E:F")) - s + 4
  8.    For Each A In .Range(.[A2], .[A2].End(xlDown))
  9. ReDim ar(0 To 1, 0 To n)
  10.        m = A & "," & A.Offset(, 1) & "," & A.Offset(, 2)
  11.        If IsEmpty(d(m)) Then
  12.        GoTo 10
  13.        Else
  14.        For i = 0 To 1
  15.          For j = 0 To n
  16.            ar(i, j) = d(m)(i, j)
  17.          Next
  18.        Next
  19.        End If
  20. 10
  21.        x = A.Offset(, 4) - s + 4 '需求日
  22.        y = A.Offset(, 5) - s + 4 '交期
  23.        For i = 0 To 2
  24.          ar(0, i) = A.Offset(, i)
  25.        Next
  26.        ar(0, 3) = "需求日"
  27.        ar(1, 3) = "交期"
  28.        If x > 0 Then ar(0, x) = ar(0, x) + A.Offset(, 3) '需求避免Sheet1內需求日無日期
  29.        If y > 0 Then ar(1, y) = A.Offset(, 3) '交期避免Sheet1內交期無日期
  30.        d(m) = ar
  31.        Erase ar
  32.    Next
  33. End With
  34. r = 2
  35. For Each ky In d.keys
  36.   .Cells(r, 1).Resize(2, n + 1) = d(ky)
  37.   r = r + 2
  38. Next
  39. End With
  40. End Sub
複製代碼
作者: p6703    時間: 2012-5-3 21:38

真是太感謝Hsieh版主，解決了小弟的大問題，執行已可自動套出

如果小弟想再加入多一些的資料（例原只有訂單,料號,項次，想再增加客戶,規格...）==>已更新附件中，請問如何修改???

小弟有自己測試修改，但功力實在不足，改後還是無法套出正確資料，故煩請Hsieh版主幫忙

[attach]10794[/attach]
作者: p6703    時間: 2012-5-8 22:35

小弟有延伸性問題想再請問版主,是否可依明細中的需求日期及數量，於Sheet2對應的欄位最後一欄秀出附件中希望的資料???

[attach]10869[/attach]
作者: p6703    時間: 2012-5-8 23:03

感謝Hsieh版主，小弟會好好研究程式碼的，希望有朝一日自己也可靈活運用，另剛小弟提問的另一項功能，是否也可以巨集達成呢???
作者: Hsieh    時間: 2012-5-8 23:29

回復 21# p6703
  1. Sub Ex()
  2. Dim A As Range, x#, y#
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With Sheet2 's("Sheet2")
  5. s = Application.Min(.Rows(1))
  6. With Sheets("Sheet1")
  7. n = Application.Max(.Columns("G:H")) - s + 6
  8.    For Each A In .Range(.[A2], .[A2].End(xlDown))
  9. ReDim ar(0 To 1, 0 To n)
  10.        m = A & "," & A.Offset(, 1) & "," & A.Offset(, 2) '訂單、料號、項次為索引
  11.        If IsEmpty(d(m)) Then
  12.        GoTo 10
  13.        Else
  14.        For i = 0 To 1
  15.          For j = 0 To n
  16.            ar(i, j) = d(m)(i, j)
  17.          Next
  18.        Next
  19.        End If
  20. 10
  21.        x = A.Offset(, 6) - s + 6 '需求日
  22.        y = A.Offset(, 7) - s + 6 '交期
  23.        For i = 0 To 4
  24.          ar(0, i) = A.Offset(, IIf(i >= 3, i + 1, i))
  25.        Next
  26.        ar(0, 5) = "需求日"
  27.        ar(1, 5) = "交期"
  28.        If x > 0 Then ar(0, x) = ar(0, x) + A.Offset(, 3) '需求避免Sheet1內需求日無日期
  29.        If y > 0 Then ar(1, y) = A.Offset(, 3) '交期避免Sheet1內交期無日期
  30.        d(m) = ar
  31.        Erase ar
  32.    Next
  33. End With
  34. r = 2
  35. For Each ky In d.keys
  36.   .Cells(r, 1).Resize(2, n + 1) = d(ky)
  37.   For i = 0 To 1
  38.   mystr = ""
  39.   Set Rng = .Range("G" & r).Offset(i).Resize(, n - 5)
  40.   If Application.CountA(Rng) > 0 Then
  41.       For Each A In Rng.SpecialCells(xlCellTypeConstants)
  42.         mystr = IIf(mystr = "", .Cells(1, A.Column).Text & "*" & A / 1000 & "K", mystr & "，" & .Cells(1, A.Column).Text & "*" & A / 1000 & "K")
  43.       Next
  44.       .Cells(r + i, "CF") = mystr
  45.   End If
  46.   Next
  47.   r = r + 2
  48. Next
  49. End With
  50. End Sub
複製代碼
作者: p6703    時間: 2012-5-9 12:29

Hsieh版主你真的太神了，感謝你，小弟會好好先研究程式碼的，再次感謝!!!
作者: p6703    時間: 2012-7-4 13:33

Hsieh版主小弟又有問題請教，原Sheet2 F欄位需求日及交期需再增加一入庫列
但入庫此資料尚不會在Sheet1中，只是每筆訂單於排程表中變成固定要做成三列，請教巨集如何修改???

F欄位
需求日
交期
入庫
作者: p6703    時間: 2012-10-15 15:25     標題: 依訂單資料轉換成六週排程表，敬請各位大大賜教!!!

本次提問的問題，主要延續原以下的發帖內容，但因本次需求較為複雜，故特再另開一新話題，請教各位先進指教
http://forum.twbts.com/viewthrea ... a=pageD1&page=1

如附件中，加入之前Hsieh版主編寫的巨集，希望修改的地方：

1.原欄位由A~E增加至A~J欄位，除了J欄位是捉取其他的資料外，其餘均由Sheet1資料中截取得出

2.原一筆訂單由二列匯整而成，修改為3列（需求日、交期、實際出貨）

3.依輸入日期自動展出排程表六週日期（如附件，輸入10/1起捉取42天的日期，包含六日）

4.延伸第三點，將訂單資料判定僅將符合此期間之訂單資料捉入（符合需求日即需代入，例：需求日10/14，但交期回覆至11/20，則此筆捉入排程表中僅於10/14有列出其需求數；需求日一旦不符此日期範圍內，該筆訂單即不列入）

5.巨集執行排出排程表後，將Sheet1中有列入排程及無列入的再各存成一工作表（工作表名稱：有列入，無列入）

6.排程表巨集最後程式碼是小弟以土法練鋼方式將各排程表首列以巨集執行跑出後，再將對應的第二及第三列複製第一列的資料，再貼上值（因合併欄位無法篩選查看出該訂單資料，故小弟只能以上方法將一筆訂單變成三筆），程式碼是否可再修改???

本次修改之處較多，且往後仍有可能會有一些延伸的問題，希望各位大大能不吝賜交，在此先感謝各位....

[attach]12777[/attach]
作者: p6703    時間: 2012-10-17 23:49

小弟知道一次提了太多問題,還是針對各別問題請各位先進可解的可先不吝賜教,小弟在此先再道謝^^



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