- 帖子
- 13
- 主題
- 0
- 精華
- 0
- 積分
- 63
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- office 365
- 閱讀權限
- 20
- 性別
- 女
- 註冊時間
- 2022-2-1
- 最後登錄
- 2024-11-20
|
12#
發表於 2022-4-21 14:14
| 只看該作者
TXT資料複製到Csv的程式碼對嗎!- Option Explicit
- Dim WB As Workbook, Csv_File As String, Txt_File As String, Txt_Path As String, Csv_Path As String, Save_Path As String
- Sub Ex_Main()
- Dim Msg As Variant
- 檢查資料夾
- Application.ScreenUpdating = False
- Application.StatusBar = " 程式執行中...................."
- Csv_File = Dir(Csv_Path & "\*.csv")
- Msg = Csv_File
- Do While Csv_File <> ""
- Txt_File = Txt_Path & "\" & Split(Csv_File, ".")(0) & ".txt" '修改csv 副檔名 為txt
- If CreateObject("Scripting.FileSystemObject").FileExists(Txt_File) = False Then MsgBox "找不到 " & vbLf & Txt_File & vbLf & "檢查後 重新執行程式!": End
- Set WB = Workbooks.Open(Csv_Path & Csv_File)
- TXT複製至CSV
- Csv_File = Dir()
- Msg = Msg & vbLf & Csv_File
- Loop
- Application.StatusBar = False
- Application.ScreenUpdating = True
- Msg = Split(Msg, vbLf)
- MsgBox Join(Msg, vbLf) & "完成TXT複製至CSV " & UBound(Msg) & " 個檔案"
- End Sub
- Private Sub 檢查資料夾()
- Dim Msg As String
- Save_Path = ThisWorkbook.Path & "\Test\" 'TXT複製至CSV 存檔的資料夾
- Csv_Path = ThisWorkbook.Path & "\csv檔\" 'csv檔檔的資料夾
- Txt_Path = ThisWorkbook.Path & "\TXT檔\" 'TXT檔的資料夾
- If Dir(Save_Path, vbDirectory) = "" Then
- If MsgBox("建立 " & Save_Path & " 資料夾", vbYesNo) = vbYes Then
- MkDir (Save_Path)
- End If
- End If
- If Dir(Csv_Path, vbDirectory) = "" Then Msg = "找不到 " & Csv_Path
- If Dir(Txt_Path, vbDirectory) = "" Then Msg = Msg & vbLf & "找不到 " & Txt_Path
- If Msg <> "" Then MsgBox Msg & vbLf & "檢查後 重新執行程式!": End
- End Sub
- Private Sub TXT複製至CSV()
- Dim Sh As Worksheet, Rng As Range
- Set Sh = Workbooks.Open(Txt_File).Sheets(1) '開啟TXT的Sheets(1)
- Set Rng = WB.Sheets(1).Range("a1").End(xlDown).Offset(1) 'TXT資料複製到Csv的指定位置
- If Rng.Row = Rows.Count Then Set Rng = WB.Sheets(1).Range("a1")
- '指定位置的Row= Rows.Count **指定位置在檔案底部時 --A欄中沒有資料
- With Sh.Range("A1") '資料剖析A欄 -,,,-> Comma:=True
- .CurrentRegion.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
- TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
- Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
- :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
- .CurrentRegion.Copy Rng '**TXT資料複製到Csv
- End With
- Sh.Parent.Close False 'Sh(Worksheet).Parent(父層-Workbook)關閉
- If CreateObject("Scripting.FileSystemObject").FileExists(Save_Path & Csv_File) Then Kill Save_Path & Csv_File
- '**CreateObject("Scripting.FileSystemObject").FileExists=True **表檔案存在,故執行 Kill
- With WB
- .SaveAs Save_Path & Csv_File '-Workbook另存\Test\ 的 Csv檔
- '**** FileExists=True ** .SaveAs 會提示是否取代原檔案-- 程式暫時中斷執行
- .Close True
- End With
- End Sub
|
|
