返回列表 上一主題 發帖

Excel 2007 VBA讀TXT檔並轉置

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
1# 跳轉到 »
發表於 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
複製代碼

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
2#
發表於 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
複製代碼

TOP

        靜思自在 : 一個人不怕錯，就怕不改過，改過並不難。
返回列表 上一主題