samwang

回復 10# 癡肥羔羊

更改如下紅字，請再測試看看，謝謝
Dim PH$, FN$, Arr(1 To 65536, 1 To 3)

lee88

TXT資料複製到Csv的程式碼對嗎!

1. Option Explicit
   
2. Dim WB As Workbook, Csv_File As String, Txt_File As String, Txt_Path As String, Csv_Path As String, Save_Path As String
   
3. Sub Ex_Main()
   
4.     Dim Msg As Variant
   
5.     檢查資料夾
   
6.     Application.ScreenUpdating = False
   
7.     Application.StatusBar = "            程式執行中...................."
   
8.     Csv_File = Dir(Csv_Path & "\*.csv")
   
9.     Msg = Csv_File
   
10.     Do While Csv_File <> ""
    
11.         Txt_File = Txt_Path & "\" & Split(Csv_File, ".")(0) & ".txt"                    '修改csv 副檔名 為txt
    
12.         If CreateObject("Scripting.FileSystemObject").FileExists(Txt_File) = False Then MsgBox "找不到 " & vbLf & Txt_File & vbLf & "檢查後 重新執行程式!": End
    
13.         Set WB = Workbooks.Open(Csv_Path & Csv_File)
    
14.         TXT複製至CSV
    
15.         Csv_File = Dir()
    
16.         Msg = Msg & vbLf & Csv_File
    
17.     Loop
    
18.     Application.StatusBar = False
    
19.     Application.ScreenUpdating = True
    
20.     Msg = Split(Msg, vbLf)
    
21.     MsgBox Join(Msg, vbLf) & "完成TXT複製至CSV  " & UBound(Msg) & " 個檔案"
    
22. End Sub
    
23. Private Sub 檢查資料夾()
    
24.     Dim Msg As String
    
25.     Save_Path = ThisWorkbook.Path & "\Test\"                     'TXT複製至CSV  存檔的資料夾
    
26.     Csv_Path = ThisWorkbook.Path & "\csv檔\"                     'csv檔檔的資料夾
    
27.     Txt_Path = ThisWorkbook.Path & "\TXT檔\"                     'TXT檔的資料夾
    
28.     If Dir(Save_Path, vbDirectory) = "" Then
    
29.          If MsgBox("建立 " & Save_Path & "  資料夾", vbYesNo) = vbYes Then
    
30.             MkDir (Save_Path)
    
31.          End If
    
32.     End If
    
33.     If Dir(Csv_Path, vbDirectory) = "" Then Msg = "找不到 " & Csv_Path
    
34.     If Dir(Txt_Path, vbDirectory) = "" Then Msg = Msg & vbLf & "找不到 " & Txt_Path
    
35.     If Msg <> "" Then MsgBox Msg & vbLf & "檢查後 重新執行程式!": End
    
36. End Sub
    
37. Private Sub TXT複製至CSV()
    
38.     Dim Sh As Worksheet, Rng As Range
    
39.     Set Sh = Workbooks.Open(Txt_File).Sheets(1)                              '開啟TXT的Sheets(1)
    
40.     Set Rng = WB.Sheets(1).Range("a1").End(xlDown).Offset(1)   'TXT資料複製到Csv的指定位置
    
41.     If Rng.Row = Rows.Count Then Set Rng = WB.Sheets(1).Range("a1")
    
42.     '指定位置的Row= Rows.Count  **指定位置在檔案底部時 --A欄中沒有資料
    
43.     With Sh.Range("A1")                     '資料剖析A欄  -,,,-> Comma:=True
    
44.         .CurrentRegion.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
    
45.             TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    
46.             Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
    
47.             :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    
48.         .CurrentRegion.Copy Rng    '**TXT資料複製到Csv
    
49.     End With
    
50.     Sh.Parent.Close False                                  'Sh(Worksheet).Parent(父層-Workbook)關閉
    
51.     If CreateObject("Scripting.FileSystemObject").FileExists(Save_Path & Csv_File) Then Kill Save_Path & Csv_File
    
52.         '**CreateObject("Scripting.FileSystemObject").FileExists=True **表檔案存在,故執行  Kill
    
53.     With WB
    
54.         .SaveAs Save_Path & Csv_File               '-Workbook另存\Test\ 的 Csv檔
    
55.         '****   FileExists=True **  .SaveAs 會提示是否取代原檔案--   程式暫時中斷執行
    
56.         .Close True
    
57.     End With
    
58. End Sub

複製代碼

回復 3# 癡肥羔羊

lee88

1. Sub Ex_Main()
   
2.     Dim Msg As Variant
   
3.     檢查資料夾
   
4.     Application.ScreenUpdating = False
   
5.     Application.StatusBar = "            程式執行中...................."
   
6.     Csv_File = Dir(Csv_Path & "\*.csv")
   
7.     Msg = Csv_File
   
8.     Do While Csv_File <> ""
   
9.         Txt_File = Txt_Path & "\" & Split(Csv_File, ".")(0) & ".txt"                    '修改csv 副檔名 為txt
   
10.         If CreateObject("Scripting.FileSystemObject").FileExists(Txt_File) = False Then MsgBox "找不到 " & vbLf & Txt_File & vbLf & "檢查後 重新執行程式!": End
    
11.         Set WB = Workbooks.Open(Csv_Path & Csv_File)
    
12.         TXT複製至CSV
    
13.         Csv_File = Dir()
    
14.         Msg = Msg & vbLf & Csv_File
    
15.     Loop
    
16.     Application.StatusBar = False
    
17.     Application.ScreenUpdating = True
    
18.    '**********加上這If 判斷程式碼 ,程式會完整些*****************
    
19. If Msg <> "" Then
    
20.         Msg = Split(Msg, vbLf)
    
21.         MsgBox Join(Msg, vbLf) & "完成TXT複製至CSV  " & UBound(Msg) & " 個檔案"
    
22.     Else
    
23.         MsgBox "沒有任何TXT檔複製至CSV檔"
    
24.     End If
    
25. '************************************************
    
26. End Sub

複製代碼

回復 12# lee88