麻辣家族討論版版 - Powered by Discuz! Board

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

複製代碼

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

複製代碼

Sub Ex()
Dim Ws(), A As Range, B As Range, s%, bs$, w As Window
For Each w In Windows
ReDim Preserve Ws(s)
Ws(s) = w.Caption
s = s + 1
Next
With ThisWorkbook.Sheets(1)
For Each A In .Range(.[M2], .[M2].End(xlDown))
bs = IIf(A = 1202, "A.xls", IIf(A = 1205, "B.xls", IIf(A = 1206, "C.xls", "")))
If IsError(Application.Match(bs, Ws, 0)) Then Workbooks.Open ThisWorkbook.Path & "\" & bs: ReDim Preserve Ws(s): Ws(s) = bs: s = s + 1
With Workbooks(bs)
Set B = .Sheets(1).[A65536].End(xlUp).Offset(1)
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)
B.Resize(, 11).Value = ar
End With
Next
End With
End Sub

複製代碼