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

Option Explicit
Sub Ex()
Dim D As Object, AR As Variant, i As Long, XPath As String, Wb As String
Set D = CreateObject("SCRIPTING.DICTIONARY") '字典物件
'將這些檔案合併寫到一個檔案裡（例如：DATA），
'目前有數個連續編號的檔案（例如：test_1　到　10），
XPath = "d:\test\ " '設有數個連續編號的檔案存於同一資料夾
Wb = Dir(XPath & "Test_*.xls") '查詢指定所需的檔案
Application.ScreenUpdating = False
Do While Wb <> "" '查詢到所需的檔案
With Workbooks.Open(XPath & Wb).Sheets(1).UsedRange
'開啟檔案第一個工作表的使用範圍
For i = 2 To .Rows.Count '第2列到最後一列
With .Rows(i)
AR = Array(.Cells(1, "c"), .Cells(1, "L"), .Cells(1, "D"), .Cells(1, "M"), .Cells(1, "F"))
'讀取 C,L,D,M,F 欄位資料
D(Join(AR, ",")) = "" '寫入字典物件的Key值
End With
Next
.Parent.Parent.Close '關閉開啟的檔案
'.UsedRange的[Parent]-> .Sheets(1)的[Parent] -> Workbooks
End With
Wb = Dir '下一個查詢的檔案
Loop
'如[DATA.xlsx] 未開啟用下式程式碼
'With Workbooks.Open(XPath & "\" & DATA.xlsx).Sheets(1)
With Workbooks("DATA.xlsx").Sheets(1)
For i = 2 To .UsedRange.Rows.Count
AR = Application.Transpose(Application.Transpose(.UsedRange.Rows(i).Value))
If D.exists(Join(AR, ",")) Then D.Remove Join(AR, ",")
'字典物件 Remove 方法,從一個 Dictionary 物件中移除一個關鍵字和項目對。
Next
For Each AR In D.keys '移除相同Key(關鍵字)後剩下的D.keys
i = .[A1].End(xlDown).Row
i = IIf(i = .Rows.Count, 2, i + 1) 'i=最後一列的列數,i=2,否i+1
With .Cells(i, "A").Resize(, 5)
.Value = Split(AR, ",")
.Cells(5).NumberFormatLocal = "[>99999999]0000-000-000;000-000-000"
.Value = .Value '數字為文字格式轉為數字格式
End With
Next
.Save '存檔
End With
Application.ScreenUpdating = True
End Sub

複製代碼