12
返回列表 上一主題 發帖

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

p6703

帖子
134 
主題
27 
精華
0 
積分
168 
點名
0  
作業系統
WINXP 
軟體版本
EXCEL 2003 
閱讀權限
20 
性別
男 
來自
雲林 
註冊時間
2010-10-6 
最後登錄
2018-5-13 

論壇贊助勳章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2012-7-11 09:13 | 只看該作者

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

小弟於工作會有一訂單明細工作表，希望可依計劃員，分別將其資料複製至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)
收藏 分享

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 2012-7-11 16:15 | 只看該作者
回復 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
複製代碼

TOP

p6703

帖子
134 
主題
27 
精華
0 
積分
168 
點名
0  
作業系統
WINXP 
軟體版本
EXCEL 2003 
閱讀權限
20 
性別
男 
來自
雲林 
註冊時間
2010-10-6 
最後登錄
2018-5-13 

論壇贊助勳章
3#
發表於 2012-7-11 22:08 | 只看該作者
感謝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

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 2012-7-12 17:44 | 只看該作者
回復 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 請按回覆鍵 ,論壇會通知我有回覆的帖子

TOP

p6703

帖子
134 
主題
27 
精華
0 
積分
168 
點名
0  
作業系統
WINXP 
軟體版本
EXCEL 2003 
閱讀權限
20 
性別
男 
來自
雲林 
註冊時間
2010-10-6 
最後登錄
2018-5-13 

論壇贊助勳章
5#
發表於 2012-7-12 23:34 | 只看該作者
感謝GBKEE版主巨集已符合小弟的需求，先研究看看，有問題再請教了，再次感謝^^

TOP

p6703

帖子
134 
主題
27 
精華
0 
積分
168 
點名
0  
作業系統
WINXP 
軟體版本
EXCEL 2003 
閱讀權限
20 
性別
男 
來自
雲林 
註冊時間
2010-10-6 
最後登錄
2018-5-13 

論壇贊助勳章
6#
發表於 2012-7-16 10:22 | 只看該作者
GBKEE版主這幾日使用有幾問題再請教，仍再麻煩了，先在此敬謝：

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

TOP

p6703

帖子
134 
主題
27 
精華
0 
積分
168 
點名
0  
作業系統
WINXP 
軟體版本
EXCEL 2003 
閱讀權限
20 
性別
男 
來自
雲林 
註冊時間
2010-10-6 
最後登錄
2018-5-13 

論壇贊助勳章
7#
發表於 2012-7-19 18:08 | 只看該作者
還請GBKEE版主幫忙是否可達成小弟需求的功能,以便套取時更方便,謝謝...^^

TOP

p6703

帖子
134 
主題
27 
精華
0 
積分
168 
點名
0  
作業系統
WINXP 
軟體版本
EXCEL 2003 
閱讀權限
20 
性別
男 
來自
雲林 
註冊時間
2010-10-6 
最後登錄
2018-5-13 

論壇贊助勳章
8#
發表於 2012-9-25 17:05 | 只看該作者
老問題一直未解決，再次詢問高手解惑
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

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
254  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-23 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
9#
發表於 2012-9-25 20:11 | 只看該作者
回復 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
複製代碼
學海無涯_不恥下問

TOP

p6703

帖子
134 
主題
27 
精華
0 
積分
168 
點名
0  
作業系統
WINXP 
軟體版本
EXCEL 2003 
閱讀權限
20 
性別
男 
來自
雲林 
註冊時間
2010-10-6 
最後登錄
2018-5-13 

論壇贊助勳章
10#
發表於 2012-9-26 08:46 | 只看該作者
感謝Hsieh 版主，小弟有一問題再請問，如果於A~C報表原固定欄位即有公式，如何在將新資料COPY到報表時，將各欄位的公式直接延伸套用????

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

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

資料.rar (24.63 KB)

TOP

        靜思自在 : 天上最美是星星，人生最美是溫情。
12
返回列表 上一主題