返回列表 上一主題 發帖

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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 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

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-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

        靜思自在 : 做好事不能少我一人，做壞事不能多我一人。
返回列表 上一主題