- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
3#
發表於 2015-7-15 08:35
| 只看該作者
回復 2# kuhsuanchieh
試試看- 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
|
|
發表於 2015-7-14 17:43
| 
