Excel 2007 VBA讀TXT檔並轉置

alexsas38

在c:\file\下有1.txt,2.txt....不一定有幾個檔案,檔名為數字遞增. 每個檔案格式都相同,如下:
例如: 1.txt
名字 王xx
數學 58
英文 63
地理 90
化學 80

2.txt
名字 林x
數學 100
英文 6
地理 60
化學  58

txt中固定都是5 rows, 2 columns, column間用空格格開, 要用迴圈將c:\file\下的50個檔案讀入Excel,並轉置成下,row 1固定是欄位名稱, row 2開始分別讀入所有檔轉置, 但只讀到地理, 不讀入化學那一row資料.
名字 數學 英文 地理
王xx 58 63 90
林x 100 6 60
.
.
.
到最後txt那筆

最後存成c:\file\final.xls

感謝!

stillfish00

回復 1# alexsas38

1. Sub TEST()
   
2.     Dim fd, f, fo
   
3.    
   
4.     With Workbooks.Add
   
5.         '標題列
   
6.         .Sheets(1).Range("A1:D1") = Array("名字", "數學", "英文", "地理")
   
7.         '新增暫存資料表
   
8.         With .Sheets.Add(after:=.Sheets(.Sheets.Count))
   
9.             '瀏覽選擇資料夾
   
10.             With Application.FileDialog(msoFileDialogFolderPicker)
    
11.                 .AllowMultiSelect = False
    
12.                 If .Show = -1 Then fd = .SelectedItems(1) & "\"
    
13.             End With
    
14.             '對所有該資料夾下的txt處理
    
15.             f = Dir(fd & "*.txt")
    
16.             Do While f <> ""
    
17.                 .Cells.ClearContents
    
18.                 '匯入外部資料
    
19.                 With .QueryTables.Add(Connection:="TEXT;" & fd & f, Destination:=.Range("A1"))
    
20.                     .Name = "成績"
    
21.                     .RefreshPeriod = 0
    
22.                     .TextFileParseType = xlDelimited
    
23.                     .TextFileConsecutiveDelimiter = True
    
24.                     .TextFileTabDelimiter = True    'Tab鍵為分割字元
    
25.                     .TextFileSemicolonDelimiter = False
    
26.                     .TextFileCommaDelimiter = False
    
27.                     .TextFileSpaceDelimiter = True  '空白鍵為分割字元
    
28.                     .Refresh BackgroundQuery:=False
    
29.                 End With
    
30.                 '刪除資料連線
    
31.                 .Cells.QueryTable.Delete
    
32.                 '新增資料到第一個工作表
    
33.                 .Parent.Sheets(1).Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 4).Value = Application.Transpose(.Range("B1:B4").Value)
    
34.                 f = Dir
    
35.             Loop
    
36.             '刪除暫存資料表,不顯示警告視窗
    
37.             Application.DisplayAlerts = False
    
38.             .Delete
    
39.             Application.DisplayAlerts = True
    
40.         End With
    
41.         .Sheets(1).Activate '使開啟該檔時直接到第一個工作表
    
42.         '存檔
    
43.         fo = Application.GetSaveAsFilename(InitialFileName:=fd & "final.xls", FileFilter:="Excel Files (*.xls),*.xls", Title:="儲存檔案")
    
44.         '除非按取消, 否則存檔
    
45.         If TypeName(fo) = "String" Then .SaveAs Filename:=fo, FileFormat:=xlExcel8
    
46.     End With
    
47. End Sub

複製代碼

alexsas38

stillfish00您好, 若資料改程如下:
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 )
.
.
.
根據您的程式修改如下:
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. "登記營業項目",也有像第二項一樣的問題,(後是空白,後面的資料就會不見.

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

alexsas38

回復 2# stillfish00
謝謝, 但是資料改變後, 會因為0和空白造成問題, 想再向您請教, 感謝您!

stillfish00

回復 4# alexsas38
這樣檔案只能自己用Split剖析：

1. Sub TEST()
   
2.     Dim fd, f, fo
   
3.     Dim ar(), fnum As Integer, i, s
   
4.     Dim arData() As String, dataLine As String
   
5.    
   
6.     ReDim ar(0)
   
7.     ar(0) = Array("營業人統一編號", "負責人姓名", "營業人名稱", "營業（稅籍）登記地址", "資本額(元)", "組織種類", "設立日期", "登記營業項目")
   
8.    
   
9.     With Workbooks.Add
   
10.         '瀏覽選擇資料夾
    
11.         With Application.FileDialog(msoFileDialogFolderPicker)
    
12.             If .Show = -1 Then
    
13.                 If .SelectedItems.Count > 0 Then fd = .SelectedItems(1) & "\"
    
14.             Else
    
15.                 Exit Sub    '取消
    
16.             End If
    
17.         End With
    
18.         '對所有該資料夾下的txt處理
    
19.         f = Dir(fd & "*.txt")
    
20.         Do While f <> ""
    
21.             '讀取檔案
    
22.             fnum = FreeFile
    
23.             Open fd & f For Input As #fnum
    
24.             '用Split剖析前八行資料
    
25.             ReDim arData(0 To 7)
    
26.             For i = 0 To 7
    
27.                 If EOF(fnum) Then Exit For  '若檔案未達八行則跳出
    
28.                 Line Input #fnum, dataLine
    
29.                 s = Split(dataLine, " ", 2)     '限制最多傳回的子字串數為2個
    
30.                 If UBound(s) = 1 Then arData(i) = s(1)
    
31.             Next
    
32.             ReDim Preserve ar(UBound(ar) + 1)   '保留並增大陣列
    
33.             ar(UBound(ar)) = arData
    
34.             Close #fnum     '記得關檔案
    
35.             f = Dir
    
36.         Loop
    
37.         With .Sheets(1)
    
38.             .Columns("A:A").NumberFormatLocal = "@"     'A欄格式設為文字
    
39.             .Range("A1").Resize(UBound(ar) + 1, 8).Value = Application.Transpose(Application.Transpose(ar))   '填入資料
    
40.             .Range("A1").Resize(UBound(ar) + 1, 8).EntireColumn.AutoFit   '調整欄寬
    
41.         End With
    
42.         '存檔
    
43.         fo = Application.GetSaveAsFilename(InitialFileName:=fd & "final.xls", FileFilter:="Excel Files (*.xls),*.xls", Title:="儲存檔案")
    
44.         '除非按取消, 否則存檔
    
45.         If TypeName(fo) = "String" Then .SaveAs Filename:=fo, FileFormat:=xlExcel8
    
46.     End With
    
47. End Sub

複製代碼

alexsas38

回復 5# stillfish00
感謝您, 我後來用len做長度判斷,再加上用&做合併的方式解決,但還是您的做法是比較effective. Thanks.