Excel 2007 VBA讀TXT檔並轉置 part 2

alexsas38

若資料改程如下:
1.txt
營業人統一編號 11111111
負責人姓名 許xx
營業人名稱 xx企業社
營業（稅籍）登記地址 xx市xx區xx里xx路xx巷xx號x樓
資本額(元) 100000
組織種類 獨資( 6 )
設立日期 1020723
登記營業項目 普通倉儲經營( 530100 )
船上貨物裝卸( 525912 )
包裝承攬服務( 820914 )

2.txt
營業人統一編號 01111111
負責人姓名 黃xx
營業人名稱 xx企業社
營業（稅籍）登記地址 xx市xx區xx里xx路xx巷xx－x號x樓
資本額(元) 60000
組織種類 獨資( 6 )
設立日期 0780522
登記營業項目 其他金屬模具製造( 251299 )
.
.
.
根據stillfish00大大的程式修改如下:
Sub importtxt()
    Dim path, folder, fname
    With Workbooks.Add '標題列

        .Sheets(1).Range("A1:H1") = Array("營業人統一編號", "負責人姓名", "營業人名稱", "營業（稅籍）登記地址", "資本額(元)", "組織種類", "設立日期", "登記營業項目")

        '新增暫存資料表

        With .Sheets.Add(after:=.Sheets(.Sheets.Count))

            '瀏覽選擇資料夾

            With Application.FileDialog(msoFileDialogFolderPicker)

                .AllowMultiSelect = False

                If .Show = -1 Then path = .SelectedItems(1) & "\"

            End With

            '對所有該資料夾下的txt處理

            folder = Dir(path & "*.txt")

            Do While folder <> ""

                .Cells.ClearContents

                '匯入外部資料

                With .QueryTables.Add(Connection:="TEXT;" & path & folder, Destination:=.Range("A1"))

                    .Name = "資料"
                    .RefreshPeriod = 0

                    .TextFileSpaceDelimiter = True  '空白鍵為分割字元

                    .Refresh BackgroundQuery:=False

                End With

                '刪除資料連線

                .Cells.QueryTable.Delete

                '新增資料到第一個工作表

                .Parent.Sheets(1).Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 8).Value = Application.Transpose(.Range("B1:B8").Value)

                folder = Dir

            Loop

            '刪除暫存資料表,不顯示警告視窗

            Application.DisplayAlerts = False

            .Delete

            Application.DisplayAlerts = True

        End With

        .Sheets(1).Activate '使開啟該檔時直接到第一個工作表

        '存檔

        fname = Application.GetSaveAsFilename(InitialFileName:=path & "final.xls", FileFilter:="Excel Files (*.xls),*.xls", Title:="儲存檔案")

        '除非按取消, 否則存檔

        If TypeName(fname) = "String" Then .SaveAs Filename:=fname, FileFormat:=xlExcel8

    End With

End Sub


但是會有3個問題,
1. 若"營業人統一編號"第一碼是0, 讀入後第一碼0會不見.
2. "組織種類"的資料,例如是: 獨資( 6 ), 因為(和6中間是空白, 資料會只讀到"獨資("就停止.
3. "登記營業項目",也有像第二項一樣的問題,(後是空白,後面的資料就會不見.

想請問如何解決這三個問題? 太感謝您的幫忙了~

luhpro

回復 1# alexsas38
只要在 .Cells.ClearContents 下方加上 :
.Columns(2).NumberFormat = "@" <- 解決 0 消失的問題(將儲存格格式設為 "文字")

然後在程式開頭加上 :
Dim lRow As Long, lI As Long

接著在 .Cells.QueryTable.Delete 下方加上 :
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
For lI = 1 To lRow
If Right(.Cells(lI, 1), 1) = "(" Then .Cells(lI, 2) = .Cells(lI, 1) & " " & .Cells(lI, 2) & " " & .Cells(lI, 3): .Cells(lI, 1) = "": .Cells(lI, 3) = ""
If .Cells(lI, 3) <> "" Then .Cells(lI, 2) = .Cells(lI, 2) & " " & .Cells(lI, 3) & " " & .Cells(lI, 4): .Cells(lI, 3) = "": .Cells(lI, 4) = ""
Next lI <- 既然程式會拆開原先的文字 那麼再依照其規則把該合併的合併起來就OK了)
即可.

1. Sub importtxt()
   
2.     Dim path, folder, fname
   
3.     Dim lRow As Long, lI As Long
   
4.    
   
5.     With Workbooks.Add '標題列
   
6. 
   
7.         .Sheets(1).Range("A1:H1") = Array("營業人統一編號", "負責人姓名", "營業人名稱", "營業（稅籍）登記地址", "資本額(元)", "組織種類", "設立日期", "登記營業項目")
   
8. 
   
9.         '新增暫存資料表
   
10. 
    
11.         With .Sheets.Add(after:=.Sheets(.Sheets.Count))
    
12. 
    
13.             '瀏覽選擇資料夾
    
14. 
    
15.             With Application.FileDialog(msoFileDialogFolderPicker)
    
16. 
    
17.                 .AllowMultiSelect = False
    
18. 
    
19.                 If .Show = -1 Then path = .SelectedItems(1) & "\"
    
20. 
    
21.             End With
    
22. 
    
23.             '對所有該資料夾下的txt處理
    
24. 
    
25.             folder = Dir(path & "*.txt")
    
26. 
    
27.             Do While folder <> ""
    
28. 
    
29.                 .Cells.ClearContents
    
30.                 .Columns(2).NumberFormat = "@"
    
31.                
    
32.                 '匯入外部資料
    
33. 
    
34.                 With .QueryTables.Add(Connection:="TEXT;" & path & folder, Destination:=.Range("A1"))
    
35. 
    
36.                     .Name = "資料"
    
37.                     .RefreshPeriod = 0
    
38. 
    
39.                     .TextFileSpaceDelimiter = True  '空白鍵為分割字元
    
40. 
    
41.                     .Refresh BackgroundQuery:=False
    
42. 
    
43.                 End With
    
44. 
    
45.                 '刪除資料連線
    
46. 
    
47.                 .Cells.QueryTable.Delete
    
48.                
    
49.                 lRow = .Cells(Rows.Count, 1).End(xlUp).Row
    
50.                 For lI = 1 To lRow
    
51.                   If Right(.Cells(lI, 1), 1) = "(" Then .Cells(lI, 2) = .Cells(lI, 1) & " " & .Cells(lI, 2) & " " & .Cells(lI, 3): .Cells(lI, 1) = "": .Cells(lI, 3) = ""
    
52.                   If .Cells(lI, 3) <> "" Then .Cells(lI, 2) = .Cells(lI, 2) & " " & .Cells(lI, 3) & " " & .Cells(lI, 4): .Cells(lI, 3) = "": .Cells(lI, 4) = ""
    
53.                 Next lI
    
54. 
    
55.                 '新增資料到第一個工作表
    
56. 
    
57.                 .Parent.Sheets(1).Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 8).Value = Application.Transpose(.Range("B1:B8").Value)
    
58. 
    
59.                 folder = Dir
    
60. 
    
61.             Loop
    
62. 
    
63.             '刪除暫存資料表,不顯示警告視窗
    
64. 
    
65.             Application.DisplayAlerts = False
    
66. 
    
67.             .Delete
    
68. 
    
69.             Application.DisplayAlerts = True
    
70. 
    
71.         End With
    
72. 
    
73.         .Sheets(1).Activate '使開啟該檔時直接到第一個工作表
    
74. 
    
75.         '存檔
    
76. 
    
77.         fname = Application.GetSaveAsFilename(InitialFileName:=path & "final.xls", FileFilter:="Excel Files (*.xls),*.xls", Title:="儲存檔案")
    
78. 
    
79.         '除非按取消, 否則存檔
    
80. 
    
81.         If TypeName(fname) = "String" Then .SaveAs Filename:=fname, FileFormat:=xlExcel8
    
82. 
    
83.     End With
    
84. 
    
85. End Sub

複製代碼

Hsieh

回復 1# alexsas38

1. Sub ex()
   
2. Dim Mystr$
   
3. Cells.Clear '清除內容
   
4. '標題
   
5. ay = Array("營業人統一編號", "負責人姓名", "營業人名稱", "營業（稅籍）登記地址", "資本額(元)", "組織種類", "設立日期", "登記營業項目")
   
6. k = 1
   
7. Cells(k, 1).Resize(, 8) = ay '寫入標題列
   
8. fd = ThisWorkbook.Path & "\" '文字檔目錄
   
9. Set fso = CreateObject("Scripting.FileSystemObject")
   
10. fs = Dir(fd & "*.txt") '檔名
    
11. Do Until fs = ""
    
12. Set f = fso.OpenTextFile(fd & fs)
    
13. Mystr = f.readall '讀取內容
    
14. For Each a In ay '取消標題文字
    
15. Mystr = Replace(Mystr, a, "")
    
16. Next
    
17. ar = Split(Mystr, Chr(10)) '以分行符號切割內容
    
18. k = k + 1
    
19. Cells(k, 1).Resize(, UBound(ar) + 1) = ar '寫入儲存格
    
20. f.Close '關閉文字檔
    
21. fs = Dir '下一個檔名
    
22. Loop
    
23. End Sub

複製代碼