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

標題: [發問] 如何拆檔和結合新插入的指定文字檔 [打印本頁]

作者: luke 時間: 2012-6-2 16:44 標題: 如何拆檔和結合新插入的指定文字檔

各位大大

我有1個文字檔由300個檔案左右組合而成,並由括弧區隔如下說明
1.開啟TEST.21csv文字檔,該檔由多個csv文字檔組成,見括弧內[*檔名*],
如A01.csv,CC0001.csv和E00001.csv,檔名下方為檔案內容,
包含不同數量組合的行列數(檔案大小不相等),
直至空白列後會出現[*div*]為該檔結尾
,然後是接續下一個檔名.

問題1:如何將TEST.21csv文字檔內的全部檔案,
         依照檔案名字拆出來,
         依序拆成A01.csv,CC0001.csv和E00001.csv.

問題2:如何把新增的文字檔如BB01.csv和DD1.csv,
         依照英文檔名文字排列順序,
         按先後順序填入檔名和檔尾詞,
         放入至TEST21.csv文字檔
         並轉存成至TEST21OK.csv.
(結果如附件)

煩請先進大大指導

[attach]11229[/attach]

作者: GBKEE 時間: 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

複製代碼

作者: luke 時間: 2012-6-4 15:21

回復 2# GBKEE

當檔案名字中有連結符號 "-" 如BB-1.csv時
會出現執行階段錯誤 '1004'
[attach]11248[/attach]
煩請先進指導謝謝
[attach]11249[/attach]

作者: GBKEE 時間: 2012-6-4 15:49

回復 3# luke
BB-1.csv -> BB_1.csv

作者: luke 時間: 2012-6-4 21:16

回復 4# GBKEE

因主檔名無法修改
原#2第30列語法
E.CurrentRegion.Name = Replace(Replace(E, "*]", ""), "[*", "")
是否可將"定義名稱 " 所指向的檔名用split分割後
再加上連結符號 "-" 作關鍵字替代
如BB-1先分成 BB和數字"1"
再結合檔名成文字"BB"&"-"&"1"

以上想法
煩請指導
謝謝!

作者: GBKEE 時間: 2012-6-5 05:58

本帖最後由 GBKEE 於 2012-6-5 21:34 編輯

回復 5# luke

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 Integer
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(Sh(2).Rows.Count, 1).End(xlUp).Offset(2) = "[*" & xlCsv & "*]"
.[a1].CurrentRegion.Copy Sh(2).Cells(Sh(2).Rows.Count, 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:=xlGuess '排序[檔名]
xR = 1
Do While .Cells(xR) <> "" '匯入 "檔名"資料
xF = Application.Match(.Cells(xR), .Parent.Columns(1), 0) '尋找 "檔名"
xi = Sh(1).Cells(Sh(1).Rows.Count, 1).End(xlUp).Row
xi = IIf(xi = 1, 1, xi + 2) '第二個[*.Csv]以後須再往下位移到2列
.Parent.Cells(xF, 1).CurrentRegion.Copy Sh(1).Cells(xi, 1)
xi = Sh(1).Cells(Sh(1).Rows.Count, 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

複製代碼

作者: luke 時間: 2012-6-5 21:01

回復 6# GBKEE

帶入#6新程式後執行至第12列會出現下列錯誤信息

[attach]11272[/attach]

查下列網址時有提到為圖表變更錯誤, 但實際工作表上並無任何圖表
http://support.microsoft.com/kb/211436/zh-tw

不知此問題是否檔案過多(200~300個檔)造成

煩請指導

作者: GBKEE 時間: 2012-6-5 21:38

回復 7# luke
版本的問題
6#程式碼以更新試試看

作者: Hsieh 時間: 2012-6-5 23:24

回復 7# luke

Sub Split_CSV()
Dim Ar(), Ay()
Set d = CreateObject("Scripting.Dictionary")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
fd = ThisWorkbook.Path & "\"
fs = fd & "TEST21.csv"
Set wb = Workbooks.Open(fs)
yn = False
With wb.Sheets(1) '分割檔案
k = .UsedRange.Columns.Count
For Each a In .Range(.[A1], .Cells(.Rows.Count, 1).End(xlUp))
If yn = False And InStr(a, ".csv") > 0 Then _
yn = True: r = 1: _
f = Replace(Replace(Replace(a, "[", ""), "]", ""), "*", ""): _
Set sh = wb.Sheets.Add(after:=wb.Sheets(1))
Ar = a.Resize(, k).Value
With sh
If yn = True Then
.Cells(r, 1).Resize(, k) = Ar: r = r + 1
ReDim Preserve Ay(s)
Ay(s) = Join(Application.Transpose(Application.Transpose(Ar)), Chr(9))
s = s + 1
End If
End With
If InStr(a, "div") > 0 Then fs = fd & "結果\" & f: yn = False: sh.Move: ActiveWorkbook.SaveAs fd & "結果\" & f, 6: Workbooks(f).Close: d(f) = Join(Ay, Chr(10)): Erase Ay: s = 0
Next
End With
wb.Close 0
fs = Dir(fd & "*.csv")
Do Until fs = ""
If fs <> "TEST21.csv" Then
Set wb = Workbooks.Open(fd & fs)
With wb.Sheets(1)
k = .UsedRange.Columns.Count
ReDim Ar(k)
Ar(0) = "[*" & fs & "*]"
For i = 1 To k - 1
Ar(i) = ""
Next
ReDim Preserve Ay(s)
Ay(s) = Join(Ar, Chr(9))
s = s + 1
For Each a In .UsedRange.Columns(1).Cells
Ar = a.Resize(, k).Value
ReDim Preserve Ay(s)
Ay(s) = Join(Application.Transpose(Application.Transpose(Ar)), Chr(9))
s = s + 1
Next
ReDim Preserve Ay(s)
Ay(s) = Join(Array("", "", "", "", "", "", "", ""), Chr(9))
s = s + 1
ReDim Ar(k)
Ar(0) = "[*div*]"
For i = 1 To k - 1
Ar(i) = ""
Next
ReDim Preserve Ay(s)
Ay(s) = Join(Ar, Chr(9))
s = s + 1
d(fs) = Join(Ay, Chr(10))
Erase Ay: s = 0
End With
wb.Close 0
End If
fs = Dir
Loop
With Worksheets.Add
.[A1].Resize(d.Count, 1) = Application.Transpose(d.keys)
.[A1].Resize(d.Count, 1).Sort key1:=.[A1], Header:=xlNo
Ar = .[A1].Resize(d.Count, 1).Value
r = 1
For Each ky In Ar '組合檔案
an = Split(d(ky), Chr(10))
For j = 0 To UBound(an)
ak = Split(an(j), Chr(9))
.Cells(r, 1).Resize(, UBound(ak) + 1) = ak
r = r + 1
Next
r = r + 1
Next
.Move
ActiveWorkbook.SaveAs fd & "結果\" & "TEST21OK.csv", 6
ActiveWorkbook.Close 1
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

複製代碼

作者: luke 時間: 2012-6-6 00:08

回復 8# GBKEE

測試#6更新程式後, 目前發現有2個問題
   1.新插入的主檔名若大於原始檔TEST21時,
      如TEST22.csv(22>21)或TF.csv(TF>TE),
      雖無錯誤發生, 實際無檔案產生.

   2.主檔名帶有"Monitor"例如MonitorTempContSet.csv和MonitorTimInv.csv兩個檔案
      執行排序時會與TempContSet.csv和TimInv.csv衝突
      其情形是MonitorTempContSet.csv和MonitorTimInv.csv個共出現兩次
      並直接覆蓋後者即TempContSet.csv和TimInv.csv會從原始檔消失不見
      (但檔名MonitorAbb.csv和MonitorAbc.csv卻不會與Abb.csv和Abc.csv衝突)
      研判是排序[檔名]錯亂造成

　　以上錯誤
　煩請指導
　謝謝!

作者: GBKEE 時間: 2012-6-6 07:01

本帖最後由 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

複製代碼

作者: luke 時間: 2012-6-6 21:13

回復 9# Hsieh

謝謝H大

插入BB-1.csv和DD1.csv兩個檔所新建立的TEST21OK.csv,
其檔尾處顯示[**]如附件
[attach]11286[/attach]

作者: Hsieh 時間: 2012-6-6 21:22

回復 12# luke

我測試OK阿
[attach]11287[/attach]

作者: luke 時間: 2012-6-6 21:34

回復 11# GBKEE

   #11新修改程式測試後,
   排序情形變得很錯亂

   因檔名長和檔案很多
   我的想法是將檔案分別存檔後
   再依照排列順序
   結合一起
   如H超版於#9程式
   (但此程式採Chr(9)方式結合, 無法順利通過編譯)

   以上想法

煩請指導

作者: luke 時間: 2012-6-6 21:40

回復 14# luke

H大好

#9 第54列Ar(0) = "[*div*]"不小心打成 Ar(0) = "[**]"

謝謝回覆

作者: GBKEE 時間: 2012-6-6 21:44

回復 14# luke
排序情形變得很錯亂
可以看看嗎?

作者: luke 時間: 2012-6-6 23:48

回復 16# GBKEE

謝謝版大

存檔時如何把ANSI文字檔格式改成Unicode文字檔格式

以下是用巨集錄製語法
ActiveWorkbook.SaveAs Filename:="D:\TEST21OK.txt", _
FileFormat:=xlUnicodeText, CreateBackup:=False

應如何套到#9和#11程式?

煩請指導謝謝

作者: GBKEE 時間: 2012-6-7 06:25

回復 17# luke
Sh(1).Parent.Close True
Sh(1).Parent.SaveAs Filename:="D:\TEST21OK.txt", FileFormat:=xlUnicodeText, CreateBackup:=False

ActiveWorkbook.SaveAs fd & "結果\" & "TEST21OK.csv", 6
ActiveWorkbook.SaveAs "D:\TEST21OK.txt", FileFormat:=xlUnicodeText, CreateBackup:=False

作者: luke 時間: 2012-6-7 19:12

本帖最後由 luke 於 2012-6-7 21:20 編輯

回復 18# GBKEE

謝謝版大

文字檔存檔格式已解決.

TEST21OK.csv檔案可否按照順序除去檔案首列名字[*檔名.csv*]和檔案結尾[*div*]和前一個空白列,
僅留中間內容如附件所示的檔案,
(或使用#9程式於拆檔轉存Unicode文字檔格式時, 不要帶入上述檔名和結尾)

煩請指導謝謝!
[attach]11312[/attach]

作者: luke 時間: 2012-6-7 21:43

回復 18# GBKEE

文件已上傳

煩請指導謝謝

作者: GBKEE 時間: 2012-6-8 10:40

回復 20# luke

Option Explicit
Sub 刪檔名()
Dim xi As Integer
With Workbooks("TEST21OK.CSV").Sheets(1)
.[A:A].Replace "[*]", "=1/0"
.Range("A:A").SpecialCells(xlCellTypeFormulas, xlErrors).Name = "xx"
.Range("xx").EntireRow.Delete
.Range("a:a").SpecialCells(xlCellTypeBlanks).Name = "xx"
For xi = 1 To .Range("xx").Areas.Count - 1
.Range("xx").Areas(xi).Cells(1).EntireRow.Delete
Next
End With
End Sub

複製代碼

作者: luke 時間: 2012-6-8 13:57

回復 21# GBKEE

版大好

我想將檔案做拆檔即開啟TEST21.csv文字檔,
找到[*檔名.csv*]和結尾詞[*div*],
將兩者之間的檔案內容取出後,
按順序存成Unicode文字檔格式.

例如: 此檔TEST21.csvㄝ數量有5個檔案,
依據每個檔案對應內容轉存成5個新檔.
A01.csv
BB-1.csv
CC0001.csv
DD1.csv
E00001.csv
(PS: [*檔名.csv*]和結尾詞[*div*]不要存入新檔)

[attach]11318[/attach]

作者: GBKEE 時間: 2012-6-8 16:31

回復 22# luke

Option Explicit
Sub 拆檔()
Dim Ar(), MyPath As String, E As Range, Rng As Range, xlFileName As String
Dim ArFile(), Msg As String
'CurDir 傳回一個 Variant (String)，用來代表目前的路徑。
MyPath = CurDir & "\" '自行修改正確路徑。
If Dir(MyPath & "*.csv") <> "" Then Kill MyPath & "*.csv" '刪除目前的路徑下的.cgs 檔案
With Workbooks("TEST21.csv").Sheets(1)
Ar = .Range("a:a").Value
.Range("a:a").Replace "[*.*]", "=1/0" '[*.*] 替代為錯誤值
.Range("a:a").SpecialCells(xlCellTypeFormulas, xlErrors).Name = "xx" '定義名稱: 錯誤值的儲存格
.Range("a:a").Value = Ar
For Each E In .[XX]
Set Rng = E.CurrentRegion
Set Rng = .Range(E.Cells(2, 1), Rng.Cells(Rng.Rows.Count, Rng.Columns.Count))
xlFileName = Replace(Replace(E, "[*", ""), "*]", "")
With Workbooks.Add(1)
Rng.Copy .Sheets(1).[a1]
.SaveAs MyPath & xlFileName, xlUnicodeText
.Close 0
End With
Next
.Parent.Close 0
End With
End Sub

複製代碼

作者: luke 時間: 2012-6-8 20:55

本帖最後由 luke 於 2012-6-9 23:21 編輯

回復 23# GBKEE

測試sub 組檔()

謝謝版大

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)