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

複製代碼