[發問] 如何以Excel VBA多重匯入文字檔並指定文字為儲存格？

hellrack

各位前輩
小弟由於工作上的需要，要匯入大量文字檔，並指定某些文字為儲存格的欄位。
因小弟不曾接觸vba，第一次整理資料時耗費不少時間，從網路上搜尋資料與自己摸索了多日。只得出半套成果（如附件）。

以下為文字檔格式
中略
2c23a040 c0004941 c5031a01 0029874c 00001ff8 51211000 20130830 a5a5a5a5
00000018 00000003 00000000 00000000 00000000 00000000 00000000 00000000
00000000 00000000 00000000 00000001 00000000 00000000 00000000 00000000
00000000 00000000 00000002 00000000 00000000 00000000 00000000
Test info, tempature : 32
中略
phybist test finish result :    0.................. at [18765]
中略
Tester send msg: "<<ErrCode=00>>"

粗體字為需要抓取的字串

輸入結果希望如圖所示

下載 (31.96 KB)

2014-11-12 20:11

附件為資料原始檔與程式碼
rowdata.zip (21.72 KB)

下載次數: 11

2014-11-12 20:14

還請各位前輩指導與解惑

stillfish00

回復 1# hellrack

1. Sub Test()
   
2.   Dim vFiles, sFile
   
3.   Dim oFSO As Object, sText As String
   
4.   Dim oRegex As Object, oMatch As Object, ar
   
5.   
   
6.   vFiles = Application.GetOpenFilename(Filefilter:="文字檔 (*.log),*.log", Title:="選擇檔案(可多選)", MultiSelect:=True)
   
7.   If Not IsArray(vFiles) Then Exit Sub
   
8.   
   
9.   Set oFSO = CreateObject("Scripting.FileSystemObject")
   
10.   Set oRegex = CreateObject("Vbscript.Regexp")
    
11.   oRegex.Pattern = "DIEID:[\S\s]*?([0-9a-f]{8}\s+[0-9a-f]{8}\s+[0-9a-f]{8})[\S\s]+?" & _
    
12.                     "Test info, tempature : ([\d]+)[\S\s]+?" & _
    
13.                     "phybist test finish result :.*?\[(\d+)\][\S\s]+?" & _
    
14.                     "Tester send msg:\s*""<<(.+)>>"""
    
15.    
    
16.   With Sheets(1)
    
17.     .UsedRange.ClearContents
    
18.     .[A1].Resize(1, 4) = Array("名稱1", "名稱2", "名稱3", "名稱4")
    
19.    
    
20.     For Each sFile In vFiles
    
21.       sText = oFSO.OpenTextFile(sFile, 1).ReadAll
    
22.       If Not oRegex.Test(sText) Then MsgBox "Format is not match:" & vbCr & sFile : Exit Sub
    
23.       Set oMatch = oRegex.Execute(sText)
    
24.       ar = Array(oMatch.Item(0).submatches(0), oMatch.Item(0).submatches(1), oMatch.Item(0).submatches(2), oMatch.Item(0).submatches(3))
    
25.       .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(1, UBound(ar) + 1) = ar
    
26.     Next
    
27.     .UsedRange.EntireColumn.AutoFit
    
28.   End With
    
29. End Sub

複製代碼

mmxxxx

回復 2# stillfish00

Stillfish00大大, 今天真是學到了,
不知文字檔也可如此讀取, 並利用Regular Expression language 讀取.
太利害了.
感謝.

hellrack

回復 2# stillfish00


    感謝stillfish00大大，大幅減少小弟的工作量！再次萬分感謝！

hellrack

回復 2# stillfish00


另問stillfish00前輩
先前提供的附件為一顆的資料，若像此版更新附件中包含多顆的資料，我該怎麼修改呢？

有勞前輩指點了
updateattch.rar (3.21 KB)

update
下載次數: 7

2014-11-13 20:51

stillfish00

回復 5# hellrack

1. Sub Test()
   
2.   Dim vFiles, sFile
   
3.   Dim oFSO As Object, sText As String
   
4.   Dim oRegex As Object, oMatch As Object, ar, i, j
   
5.   
   
6.   vFiles = Application.GetOpenFilename(Filefilter:="文字檔 (*.log),*.log", Title:="選擇檔案(可多選)", MultiSelect:=True)
   
7.   If Not IsArray(vFiles) Then Exit Sub
   
8.   
   
9.   Set oFSO = CreateObject("Scripting.FileSystemObject")
   
10.   Set oRegex = CreateObject("Vbscript.Regexp")
    
11.   oRegex.Pattern = "DIEID:[\S\s]*?([0-9a-f]{8}\s+[0-9a-f]{8}\s+[0-9a-f]{8})[\S\s]+?" & _
    
12.                     "Test info, tempature : ([\d]+)[\S\s]+?" & _
    
13.                     "phybist test finish result :.*?\[(\d+)\][\S\s]+?" & _
    
14.                     "Tester send msg:\s*""<<(.+)>>"""
    
15.   oRegex.Global = True
    
16.   
    
17.   With Sheets(1)
    
18.     .UsedRange.ClearContents
    
19.     .[A1].Resize(1, 4) = Array("名稱1", "名稱2", "名稱3", "名稱4")
    
20.    
    
21.     For Each sFile In vFiles
    
22.       sText = oFSO.OpenTextFile(sFile, 1).ReadAll
    
23.       If Not oRegex.Test(sText) Then MsgBox "Format is not match:" & vbCr & sFile: Exit Sub
    
24.       Set oMatch = oRegex.Execute(sText)
    
25.       ReDim ar(0 To oMatch.Count - 1, 0 To 3)
    
26.       For i = 0 To oMatch.Count - 1
    
27.         With oMatch.Item(i)
    
28.           For j = 0 To .submatches.Count - 1
    
29.             ar(i, j) = .submatches(j)
    
30.           Next
    
31.         End With
    
32.       Next
    
33.       .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar) + 1, UBound(ar, 2) + 1) = ar
    
34.     Next
    
35.     .UsedRange.EntireColumn.AutoFit
    
36.   End With
    
37. End Sub

複製代碼

hellrack

回復 6# stillfish00

it's works
再次感謝大大的幫忙！