- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
2#
發表於 2012-6-4 11:38
| 只看該作者
本帖最後由 GBKEE 於 2012-6-4 12:06 編輯
回復 1# luke
試試看- Option Explicit
- Sub Ex()
- Dim Ar, E As Variant, xi As Integer, xlCsv As String, xlPath As String
- Dim Sh(1 To 2) As Worksheet
- xlPath = ThisWorkbook.Path & "\" '->修改為正確的檔案路徑
- Set Sh(1) = Workbooks.Open(xlPath & "test21.csv").Sheets(1)
- Set Sh(2) = Sh(1).Parent.Sheets.Add
- Sh(1).Cells.Copy Sh(2).Cells(1) '複製 test21.csv 的資料 '
- xlCsv = Dir(xlPath & "*.Csv") '尋找 *.Csv檔案
- Do While xlCsv <> "" And LCase(xlCsv) <> "test21.csv"
- With Workbooks.Open(xlPath & xlCsv).Sheets(1)
- Sh(2).Cells(Rows.Count, 1).End(xlUp).Offset(2) = "[*" & xlCsv & "*]"
- .[a1].CurrentRegion.Copy Sh(2).Cells(Rows.Count, 1).End(xlUp).Offset(1)
- .Parent.Close 0
- End With
- xlCsv = Dir
- Loop
- With Sh(2)
- .Activate
- For Each E In ActiveWorkbook.Names
- '刪除所有已定義的名稱 以避免 : 定義的名稱中有不在的 *.Csv
- E.Delete
- Next
- '*** 處裡 已匯入的 *.Csv *********
- Ar = .Range("a:a").Value
- .Range("a:a").Replace "[*.*]", "=1/0" '[*.Csv] 替代為錯誤值
- .Range("a:a").SpecialCells(xlCellTypeFormulas, xlErrors).Select '選擇有錯誤值的儲存格
- .Range("a:a").Value = Ar '複原原來的值
- For Each E In Selection
- E.CurrentRegion.Name = Replace(Replace(E, "*]", ""), "[*", "")
- '每一儲存格的延伸範圍: 定義名稱 *.Csv
- Next
- '****************************
- Sh(1).Cells.Clear 'test21.csv.Sheets(1) :清除所有資料 重新匯入排序後的*.Csv
- For Each E In ActiveWorkbook.Names '定義名稱 :會自動排序名稱
- xi = Sh(1).Cells(Rows.Count, 1).End(xlUp).Row
- xi = IIf(xi = 1, 1, xi + 2)
- Range(E.Name).Copy Sh(1).Cells(xi, 1)
- xi = Sh(1).Cells(Rows.Count, 1).End(xlUp).Row
- Sh(1).Cells(xi + 2, 1) = "[*div*]"
- Next
- Application.DisplayAlerts = False
- .Delete '刪除工作表
- Application.DisplayAlerts = True
- End With
- '***** 測試 成功後 解除註解 可存檔
- 'Sh(1).Parent.Close True
- End Sub
|
|
發表於 2012-6-4 21:16
| 
