- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
本帖最後由 GBKEE 於 2012-6-6 07:03 編輯
回復 10# luke
7# 的問題 是2003 以上的版本 使用End 屬性,如有計算 Rows.Count 或 Columns.Count 須指明它的父層物件
Sh(1).Rows.Count 或 Sh(1).Columns.Count
10# 的問題 修正用Find 取代 Match 找到 真正的字串 試試看- Option Explicit
- Sub Ex()
- Dim Sh(1 To 2) As Worksheet, Ar, E As Variant, xlCsv As String, xlPath As String
- Dim xi As Integer, xR As Integer, xF As Range, xlRowsCount As Long
- xlRowsCount = ActiveSheet.Rows.Count
- 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(xlRowsCount, 1).End(xlUp).Offset(2) = "[*" & xlCsv & "*]"
- .[a1].CurrentRegion.Copy Sh(2).Cells(xlRowsCount, 1).End(xlUp).Offset(1) '複製 *.Csv的資料
- .Parent.Close 0
- End With
- xlCsv = Dir
- Loop
- Sh(1).Cells.Clear 'test21.csv.Sheets(1) 清除所有資料: 已備重新匯入排序後的*.Csv
- '*** 處裡 已匯入的 *.Csv*********
- With Sh(2)
- .Activate
- Ar = .Range("a:a").Value
- .Range("a:a").Replace "[*.*]", "=1/0" '[*.Csv] 替代為錯誤值
- .Range("a:a").SpecialCells(xlCellTypeFormulas, xlErrors).Name = "檔名" '將有錯誤值的儲存格 定義名稱
- .Range("a:a").Value = Ar '複原原來的值
- With .Columns(Columns.Count)
- [檔名].Copy .Cells(1)
- .Sort Key1:=.Range("a1"), Order1:=xlAscending, Header:=xlNo '排序[檔名]
- xR = 1
- Do While .Cells(xR) <> "" '匯入 "檔名"資料
- Set xF = .Parent.Columns(1).Find(.Cells(xR).Text, LookAT:=xlWhole) '尋找 "檔名"
- xi = Sh(1).Cells(xlRowsCount, 1).End(xlUp).Row
- xi = IIf(xi = 1, 1, xi + 2) '第二個[*.Csv]以後 須再往下位移到2列
- xF.CurrentRegion.Copy Sh(1).Cells(xi, 1)
- xi = Sh(1).Cells(xlRowsCount, 1).End(xlUp).Row
- Sh(1).Cells(xi + 2, 1) = "[*div*]"
- xR = xR + 1
- Loop
- End With
- Application.DisplayAlerts = False
- .Delete '刪除資料暫存工作表
- Application.DisplayAlerts = True
- End With
- '*****測試 成功後 解除註解 可存檔
- 'Sh(1).Parent.Close True
- End Sub
|
|
發表於 2012-6-6 07:01
| 
發表於 2012-6-6 21:13
| 
