依指定欄位中的資料自動判定輸入對應的檔案資料中???

p6703

小弟於工作會有一訂單明細工作表，希望可依計劃員，分別將其資料複製至A,B,C三檔案中（1202-->A檔，1205-->B檔，1206-->C檔），A~C檔案中原即已有訂單資料，新增的訂單資料需新增加入（例：原A檔案中已有100列，新加入的訂單資料需自動判定從101列自動輸入）

但非整列複製，僅有部份欄位資料需新增至新報表（如下，新報表中的C,G,J欄位為自行輸入，B欄位依來源資料為IS或OS即自動填入2，否則一律為空白）

如何以巨集快速達成此一目標，請各先教指教，小弟在此先拜謝了:lol :lol

來源資料欄位                                                                               
C                        F        J        B                D        E                H
新報表欄位                                                                               
A        B        C        D        E        F        G        H        I        J        K

資料.rar (7.72 KB)

下載次數: 26

2012-7-11 09:13

GBKEE

回復 1# p6703
試試看

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim D As Object, Ar(1 To 11), Ay(), xi As Integer, K, Wb As Workbook
   
4.     Set D = CreateObject("Scripting.Dictionary")
   
5.     xi = 2
   
6.     With ThisWorkbook.Sheets("SHEET1")
   
7.         Do While .Cells(xi, "M") <> ""
   
8.             Ar(1) = .Cells(xi, "C")                         'Ar(1)->Ar(11) = A欄:K欄
   
9.             Ar(4) = .Cells(xi, "F")                         '指定不連續的欄位 到指定位置
   
10.             Ar(5) = .Cells(xi, "J")
    
11.             Ar(6) = .Cells(xi, "B")
    
12.             Ar(8) = .Cells(xi, "D")
    
13.             Ar(9) = .Cells(xi, "E")
    
14.             Ar(11) = .Cells(xi, "H")
    
15.             If Not D.exists(.Cells(xi, "M").Value) Then     '字典物件 的KEY 不存在
    
16.                 D(.Cells(xi, "m").Value) = Array(Ar)        '字典物件的item 指定為陣列
    
17.             Else                                            '字典物件的KEY存在
    
18.                 Ay = D(.Cells(xi, "M").Value)               'Ay=字典物件的ITEM
    
19.                 ReDim Preserve Ay(UBound(Ay) + 1)           '陣列的元素內容不變,新增一個元素
    
20.                 Ay(UBound(Ay)) = Ar                         '新增一個元素 指定為 Ar
    
21.                 D(.Cells(xi, "m").Value) = Ay               '字典物件的ITEM=Ay陣列
    
22.             End If
    
23.             xi = xi + 1
    
24.         Loop
    
25.     End With
    
26.     For Each K In D.keys
    
27.         If K = 1202 Then Set Wb = Workbooks("A.xls")             '檔案已開啟
    
28.         'If K = 1202 Then Set Wb = Workbooks.Open("路徑 \A.xls") '檔案未開啟
    
29.         If K = 1205 Then Set Wb = Workbooks("B.xls")
    
30.         If K = 1206 Then Set Wb = Workbooks("C.xls")
    
31.         xi = Application.CountA(Wb.Sheets(1).Range("A:A")) + 1
    
32.         Ay = Application.Transpose(Application.Transpose(D(K)))
    
33.         Wb.Sheets(1).Cells(xi, "A").Resize(UBound(Ay, 1), UBound(Ay, 2)) = Ay
    
34.         Wb.Close True                                           '關閉檔案: 存檔
    
35.     Next
    
36. End Sub

複製代碼

p6703

感謝GBKEE版主，小弟執行後有二問題請問：

1.未開啟檔案狀況下，會造成跑出錯誤訊息：執行階段錯誤 9':陣列索引超出範圍，是否可再設定即使未開啟也可自動將資料寫入（或判定未開自動開啟??）
2.B欄位依來源資料為IS或OS即自動填入2，否則一律為空白（計劃員為1205的有一筆OS及IS，希望可於B欄自動填入2）

類別        訂單號碼        項次        料號        未結數量        下單日        交期回覆日        到期日        天數        客戶代碼        客戶名稱        庫存量        計畫員
OS        AA12354        1        B        250,000.00        2012/7/8                2012/8/10                5465798                        1205
IS        AB123458        4        AA        158,789.00        2012/7/5                2012/8/13                4986798                        1205

GBKEE

回復 3# p6703

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim D As Object, Dwb As String, Ar(1 To 11), Ay(), xi As Integer, K, Wb As Workbook
   
4.     Dim W As Workbook
   
5.     Set D = CreateObject("Scripting.Dictionary")
   
6.     xi = 2
   
7.     With ThisWorkbook.Sheets("SHEET1")
   
8.         Do While .Cells(xi, "M") <> ""
   
9.             Ar(1) = .Cells(xi, "C")                         'Ar(1)->Ar(11) = A欄:K欄
   
10.             Ar(2) = IIf(.Cells(xi, "A") = "OS" Or .Cells(xi, "A") = "IS", 2, "")                       'Ar(1)->Ar(11) = A欄:K欄
    
11.             'B欄位依來源資料為IS或OS即自動填入2，否則一律為空白
    
12.             Ar(4) = .Cells(xi, "F")                         '指定不連續的欄位 到指定位置
    
13.             Ar(5) = .Cells(xi, "J")
    
14.             Ar(6) = .Cells(xi, "B")
    
15.             Ar(8) = .Cells(xi, "D")
    
16.             Ar(9) = .Cells(xi, "E")
    
17.             Ar(11) = .Cells(xi, "H")
    
18.             If Not D.exists(.Cells(xi, "M").Value) Then     '字典物件 的KEY 不存在
    
19.                 D(.Cells(xi, "m").Value) = Array(Ar)        '字典物件的item 指定為陣列
    
20.             Else                                            '字典物件的KEY存在
    
21.                 Ay = D(.Cells(xi, "M").Value)               'Ay=字典物件的ITEM
    
22.                 ReDim Preserve Ay(UBound(Ay) + 1)           '陣列的元素內容不變,新增一個元素
    
23.                 Ay(UBound(Ay)) = Ar                         '新增一個元素 指定為 Ar
    
24.                 D(.Cells(xi, "m").Value) = Ay               '字典物件的ITEM=Ay陣列
    
25.             End If
    
26.             xi = xi + 1
    
27.         Loop
    
28.     End With
    
29.     For Each K In D.keys
    
30.         If K = 1202 Then Dwb = "A.xls"             '指定檔案
    
31.         If K = 1205 Then Dwb = "B.xls"
    
32.         If K = 1206 Then Dwb = "C.xls"
    
33.         Set Wb = Nothing
    
34.         'Nothing 關鍵字是用來將一個物件變數從一個實際的物件裏分離開來。使用 Set 陳述式可指定 Nothing 給物件變數
    
35.         For Each W In Workbooks
    
36.             If W.Name = Dwb Then Set Wb = Workbooks(Dwb): Exit For                   '檔案存在 設定變數
    
37.         Next        '
    
38.         If Wb Is Nothing Then Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & Dwb) '檔案不存在 設定變數
    
39.         xi = Application.CountA(Wb.Sheets(1).Range("A:A")) + 1
    
40.         Ay = Application.Transpose(Application.Transpose(D(K)))
    
41.         Wb.Sheets(1).Cells(xi, "A").Resize(UBound(Ay, 1), UBound(Ay, 2)) = Ay
    
42.         Wb.Close True                                           '關閉檔案: 存檔
    
43.     Next
    
44. End Sub

複製代碼

PS 請按回覆鍵 ,論壇會通知我有回覆的帖子

p6703

感謝GBKEE版主巨集已符合小弟的需求，先研究看看，有問題再請教了，再次感謝^^

p6703

GBKEE版主這幾日使用有幾問題再請教，仍再麻煩了，先在此敬謝：

1.小弟將原訂單資料COPY到別檔案執行，卻無法將資料COPY到訂單報表中（但工作表名稱均為SHEET1），只能在原有巨集的檔案中執行才會動作???
2.新報表中的C欄希望可套取當天日期，G及J欄位原最後一欄已有套取公式，如何將新資料延用原公式
3.延伸另一問題，如僅只是整列複製，原巨集如何修改???可按原要求自動COPY到指定的工作表中（原工作表均已有資料，自動往最後一列開始加上該新增資料）

p6703

還請GBKEE版主幫忙是否可達成小弟需求的功能,以便套取時更方便,謝謝...^^

p6703

老問題一直未解決，再次詢問高手解惑
GBKEE版主設計的巨集可依各條件將資料COPY的各檔案的欄位中，但因該報表中一些欄位都已有設定公式自動套取數據，小弟是以下程式碼去套取原預設的公式，但其中有一個檔案套取列數會超過很多列（例：原新資料增加5列，結果執行此巨集後其增加了幾百列），請問是否此巨集可再修改套取新增加的列數就好，謝謝...^^
    Range("G2").Select
    Selection.End(xlDown).Select
    Selection.AutoFill Destination:=ActiveCell.Range("A1:A" & [H2].End(xlDown).Row)
    Range("A1:A" & [H2].End(xlDown).Row).Select

Hsieh

回復 8# p6703

1. Sub Ex()
   
2. Dim Ws(), A As Range, B As Range, s%, bs$, w As Window
   
3. For Each w In Windows
   
4. ReDim Preserve Ws(s)
   
5. Ws(s) = w.Caption
   
6. s = s + 1
   
7. Next
   
8. With ThisWorkbook.Sheets(1)
   
9.    For Each A In .Range(.[M2], .[M2].End(xlDown))
   
10.      bs = IIf(A = 1202, "A.xls", IIf(A = 1205, "B.xls", IIf(A = 1206, "C.xls", "")))
    
11.      If IsError(Application.Match(bs, Ws, 0)) Then Workbooks.Open ThisWorkbook.Path & "\" & bs: ReDim Preserve Ws(s): Ws(s) = bs: s = s + 1
    
12.      With Workbooks(bs)
    
13.      Set B = .Sheets(1).[A65536].End(xlUp).Offset(1)
    
14.      ar = Array(A.Offset(, -10).Value, IIf(A.Offset(, -12) = "IS" Or A.Offset(, -12) = "IN", 2, ""), Date, A.Offset(, -7).Value, A.Offset(, -3).Value, A.Offset(, -11).Value, B.Offset(, 6).FormulaLocal, A.Offset(, -9).Value, A.Offset(, -8).Value, B.Offset(, 9).FormulaLocal, A.Offset(, -5).Value)
    
15.      B.Resize(, 11).Value = ar
    
16.      End With
    
17.    Next
    
18. End With
    
19. End Sub

複製代碼

p6703

感謝Hsieh 版主，小弟有一問題再請問，如果於A~C報表原固定欄位即有公式，如何在將新資料COPY到報表時，將各欄位的公式直接延伸套用????

訂單報表中有公式的欄位：G、J、N、P、R、S、W

附件中的A檔案有預設公式...

資料.rar (24.63 KB)

下載次數: 8

2012-9-26 08:45