[發問] 想請教如何從一個txt檔轉出成很多個excel檔

flowrew

各位親愛的大大午安
    有個小問題想要跟各位請益，
    要如何將一個有好幾行資料的txt檔，匯出成每一行一個excel檔
    小弟目前的txt檔格式如下
   

下載 (18.5 KB)

2015-2-25 13:47

    如圖所示有三行資料
    上面SN及Model是要輸出的每個execl都要代入的
    然後三行資料各自匯到各excel
   

下載 (22.63 KB)

2015-2-25 13:53

   其中C欄的資料內有兩部分，第一部分跟第二部分中間有個空格，各自要拉到不同的excel欄位

   目前小弟只會做選檔案按鍵跟排到excel，苦手，請各位的幫忙，萬分感謝

luhpro

各位親愛的大大午安
    有個小問題想要跟各位請益，
    要如何將一個有好幾行資料的txt檔，匯出成每一行 ...
flowrew 發表於 2015-2-25 13:58

僅就你提供的圖檔猜測文字檔的內容,試試看...

1. Sub nn()
   
2.   Dim iMode%, iBgn%, iCol%
   
3.   Dim lRow&
   
4.   Dim sStr$, sTemp$
   
5.   Dim vD
   
6.   Dim vFs, vF
   
7.   
   
8.   Cells.Clear
   
9.   
   
10.   Set vD = CreateObject("Scripting.Dictionary")
    
11.   lRow = 3
    
12.   iCol = 3
    
13.   iMode = 0
    
14.   Set vFs = CreateObject("Scripting.FileSystemObject")
    
15.   Set vF = vFs.OpenTextFile(ThisWorkbook.Path & "\123.txt", 1, -2)
    
16.     Do While Not vF.AtEndOfStream
    
17.       sStr = Trim(vF.ReadLine)
    
18.       If sStr <> "" Then
    
19.       
    
20.         Select Case iMode
    
21.           Case Is > 2 ' 資料區
    
22.             iBgn = InStr(1, sStr, " ")
    
23.             Cells(vD("1"), iCol) = Left(sStr, iBgn - 1)
    
24.             
    
25.             iBgn = InStr(iBgn, sStr, " ")
    
26.             GoSub SkipSpace
    
27.             Cells(vD("2"), iCol) = sTemp
    
28.             
    
29.             iBgn = InStr(iBgn, sStr, " ")
    
30.             GoSub SkipSpace
    
31.             Cells(vD("3"), iCol) = sTemp
    
32.             
    
33.             iBgn = InStr(iBgn, sStr, " ")
    
34.             GoSub SkipSpace
    
35.             Cells(vD("3") + 1, iCol) = sTemp
    
36.             
    
37.             iBgn = InStr(iBgn, sStr, " ")
    
38.             GoSub SkipSpace
    
39.             Cells(vD("4"), iCol) = sTemp
    
40.             iCol = iCol + 1
    
41.                            
    
42.           Case 0 ' SN
    
43.             If InStr(1, sStr, "SN") > 0 Then
    
44.               Cells(lRow, 2) = "SN"
    
45.               Cells(lRow, 3) = Trim(Mid(sStr, InStr(1, sStr, ":") + 1, 10))
    
46.               iMode = iMode + 1
    
47.               lRow = lRow + 1
    
48.             End If
    
49.         
    
50.           Case 1 ' Model
    
51.             If InStr(1, sStr, "Model") > 0 Then
    
52.               Cells(lRow, 2) = "Model"
    
53.               Cells(lRow, 3) = Trim(Mid(sStr, InStr(1, sStr, ":") + 1, 10))
    
54.               iMode = iMode + 1
    
55.               lRow = lRow + 2
    
56.             End If
    
57. 
    
58.           Case 2 ' A B C D
    
59.             iBgn = InStr(1, sStr, " ")
    
60.             Cells(lRow, 2) = Left(sStr, iBgn - 1)
    
61.             vD("1") = lRow
    
62.             
    
63.             GoSub SkipSpace
    
64.             lRow = lRow + 1
    
65.             Cells(lRow, 2) = sTemp
    
66.             vD("2") = lRow
    
67.             iBgn = InStr(iBgn, sStr, " ")
    
68.             
    
69.             GoSub SkipSpace
    
70.             lRow = lRow + 2
    
71.             Cells(lRow, 2) = sTemp
    
72.             vD("3") = lRow
    
73.             iBgn = InStr(iBgn, sStr, " ")
    
74.             
    
75.             GoSub SkipSpace
    
76.             lRow = lRow + 2
    
77.             Cells(lRow, 2) = sTemp
    
78.             vD("4") = lRow
    
79.             iMode = iMode + 1
    
80.         End Select
    
81.       End If
    
82.     Loop
    
83.   vF.Close
    
84.   
    
85. Exit Sub
    
86. 
    
87. SkipSpace:
    
88.     Do While Mid(sStr, iBgn, 1) = " "
    
89.       iBgn = iBgn + 1
    
90.     Loop
    
91.     sTemp = Trim(Mid(sStr, iBgn, IIf(InStr(iBgn, sStr, " ") = 0, _
    
92.                            Len(sStr) + 1, InStr(iBgn, sStr, " ")) - iBgn))
    
93.   Return
    
94. End Sub

複製代碼

test.zip (10.16 KB)

下載次數: 4

2015-2-25 22:19

下載 (7.76 KB)

2015-2-25 22:24

flowrew

回復 2# luhpro

謝謝luhpro大的回答，解了不少疑惑，非常感謝。<(_ _)>

luhpro大的方式是把他們合成一個excel
我的目的是希望能夠從這個有三行資料的txt檔匯成3個excel
每1個excel裡面就只有一行資料
我卡在這邊動不了。

bobomi

橫的叫列, 不叫行

stillfish00

回復 1# flowrew

1. Sub Test()
   
2.     Dim vFile, oFs, oTs, sAll As String
   
3.     Dim oRegexp, oMatch
   
4.     Dim i As Long, sSN As String, sModel As String, arHeader() As String, sName As String
   
5.    
   
6.     vFile = Application.GetOpenFilename(FileFilter:="Text Files (*.txt),*.txt", Title:="選擇檔案")
   
7.     If StrComp(TypeName(vFile), "Boolean", vbTextCompare) = 0 Then Exit Sub
   
8.    
   
9.     Set oFs = CreateObject("Scripting.FileSystemObject")
   
10.     Set oTs = oFs.openTextFile(vFile, 1)
    
11.     sAll = oTs.ReadAll
    
12.     sAll = Replace(sAll, vbCrLf, vbLf)
    
13.    
    
14.     Set oRegexp = CreateObject("vbscript.regexp")
    
15.     With oRegexp
    
16.         .Pattern = "SN\s*:\s*(\S*)"
    
17.         Set oMatch = .Execute(sAll)
    
18.         If oMatch.Count > 0 Then sSN = oMatch(0).submatches(0)
    
19.         
    
20.         .Pattern = "Model\s*:\s*(\S*)"
    
21.         Set oMatch = .Execute(sAll)
    
22.         If oMatch.Count > 0 Then sModel = oMatch(0).submatches(0)
    
23.         
    
24.         'Data Header
    
25.         .MultiLine = True
    
26.         .Pattern = "^(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s*$"
    
27.         Set oMatch = .Execute(sAll)
    
28.         If oMatch.Count > 0 Then arHeader = Split(.Replace(oMatch(0), "$1,$2,$3,$4"), ",")
    
29.         
    
30.         'Data Value
    
31.         .Global = True
    
32.         .Pattern = "^(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s*$"
    
33.         Set oMatch = .Execute(sAll)
    
34.     End With
    
35.    
    
36.     sName = Left(vFile, Len(vFile) - 4)
    
37.     For i = 0 To oMatch.Count - 1
    
38.         With Workbooks.Add
    
39.             With .Sheets(1)
    
40.                 .[B3].value = "SN"
    
41.                 .[C3].value = sSN
    
42.                 .[B4].value = "Model"
    
43.                 .[C4].value = sModel
    
44.                
    
45.                 .[B6].value = arHeader(0)
    
46.                 .[C6].value = oMatch(i).submatches(0)
    
47.                 .[B7].value = arHeader(1)
    
48.                 .[C7].value = oMatch(i).submatches(1)
    
49.                
    
50.                 .[B9].value = arHeader(2)
    
51.                 .[C9].value = oMatch(i).submatches(2)
    
52.                 .[C10].value = oMatch(i).submatches(3)
    
53. 
    
54.                 .[B11].value = arHeader(3)
    
55.                 .[C11].value = oMatch(i).submatches(4)
    
56.             End With
    
57.             .SaveAs sName & "_" & i + 1 & ".xlsx"
    
58.             .Close
    
59.         End With
    
60.     Next
    
61.     MsgBox "完成"
    
62. End Sub

複製代碼

flowrew

橫的叫列, 不叫行
bobomi 發表於 2015-2-26 11:43

阿    對不起    小弟搞不清楚   感謝大大指教

flowrew

回復  flowrew
stillfish00 發表於 2015-2-26 14:08

多謝大大，真的分成三份了，太強了，感謝您的指導

flowrew

Dear  stillfish00大大

想請教一下，我用巨集錄了個form，只是簡單的上色及加上標語，拉格子大小等
希望能夠當excel每一個值帶入後(就是您寫的程式的第56列後面)加上這個巨集把excel畫面整理。
但是測試都出現1004。我沒有宣告任何東西，只是把那個巨集加上去。
後來再逐行除錯的時候，一到我加的第一行就卡住了。
再煩請您幫幫忙，感恩~
大概如下面這樣

1.   sName = Left(vFile, Len(vFile) - 4)
   
2.     For i = 0 To oMatch.Count - 1
   
3.         With Workbooks.Add
   
4.             With .Sheets(1)
   
5.                 .[B3].Value = "SN"
   
6.                 .[C3].Value = sSN
   
7.                 .[B4].Value = "Model"
   
8.                 .[C4].Value = sModel
   
9.                
   
10.                 .[B6].Value = arHeader(0)
    
11.                 .[C6].Value = oMatch(i).submatches(0)
    
12.                 .[B7].Value = arHeader(1)
    
13.                 .[C7].Value = oMatch(i).submatches(1)
    
14.                
    
15.                 .[B9].Value = arHeader(2)
    
16.                 .[C9].Value = oMatch(i).submatches(2)
    
17.                 .[C10].Value = oMatch(i).submatches(3)
    
18. 
    
19.                 .[B11].Value = arHeader(3)
    
20.                 .[C11].Value = oMatch(i).submatches(4)
    
21.             End With
    
22.         
    
23.                     Range("B2").Select
    
24.                     ActiveCell.FormulaR1C1 = "甲"
    
25.                     Range("B3").Select
    
26.                     ActiveCell.FormulaR1C1 = _
    
27.                         "乙" & Chr(10) & "丙"
    
28.                     Range("B2:H2").Select
    
29.                     With Selection
    
30.                         .HorizontalAlignment = xlCenter
    
31.                         .VerticalAlignment = xlBottom
    
32.                         .WrapText = False
    
33.                         .Orientation = 0
    
34.                         .AddIndent = False
    
35.                         .IndentLevel = 0
    
36.                         .ShrinkToFit = False
    
37.                         .ReadingOrder = xlContext
    
38.                         .MergeCells = False
    
39.                     End With

複製代碼

stillfish00

回復 8# flowrew
附檔吧，你是說有使用UserForm?  應該是要改成沒Select的寫法吧

flowrew

回復 9# stillfish00

Dear stillfish00大
我把東西放在附件裡,FYI
另外為何不能使用select，再請您指導，感恩