Board logo

標題: Excel 2007 VBA讀TXT檔並轉置 [打印本頁]
作者: alexsas38    時間: 2013-6-25 03:16     標題: Excel 2007 VBA讀TXT檔並轉置

在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    時間: 2013-6-25 10:51

回復 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    時間: 2013-6-25 19:59

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    時間: 2013-6-25 20:13

回復 2# stillfish00
謝謝, 但是資料改變後, 會因為0和空白造成問題, 想再向您請教, 感謝您!
作者: stillfish00    時間: 2013-6-25 22:42

回復 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    時間: 2013-6-26 05:25

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



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