標題:
[發問]
代碼分析求助
[打印本頁]
作者:
mrkacs
時間:
2018-6-24 00:28
標題:
代碼分析求助
[attach]28882[/attach]
[attach]28883[/attach]
能否請各位先進幫忙VB一下
1.匯入某指定資料夾所有*.txt 檔案
2.在新分頁祇顯示前綴有數字代碼之字串，不顯示無數字代碼字串(如紅色mark所示)
3.將有數字代碼下行狀況字串移到 前列代碼之後
4.將字串分割為不同欄位 如數字字串為A1 日期字串為 B1 時間字串為 C1
在新手面前感覺有點困難，望高手能幫忙 感激不盡
作者:
stillfish00
時間:
2018-6-26 10:44
回復
1#
mrkacs
Sub Example()
Dim sPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "請選擇資料夾"
If .Show = -1 Then
If .SelectedItems.Count > 0 Then sPath = .SelectedItems(1) Else Exit Sub
End If
End With
Dim oReg As Object: Set oReg = CreateObject("vbscript.regexp")
With oReg
.MultiLine = True
.Global = True
.Pattern = "^\s*(\S{1,10}) (\d{2})/(\d{2})/(\d{4}) (\d{2}:\d{2}:\d{2}) (.{15}) (.{10}) (.{10}) (.{6})\s*\r\n(.*)\r\n"
End With
Dim ws As Worksheet
Set ws = Workbooks.Add.Sheets(1)
Const ForReading = 1
Dim oFSO As Object: Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim oTF, oFD, sText
Dim curRow As Long
Dim match
Set oFD = oFSO.getfolder(sPath)
For Each f In oFD.Files
If oFSO.getextensionname(f.Path) = "txt" Then
Set oTF = oFSO.OpenTextFile(f.Path, ForReading)
sText = oTF.ReadAll
Set match = oReg.Execute(sText)
With ws
For Each it In match
curRow = curRow + 1
.Cells(curRow, 1) = Trim(it.submatches(0))
.Cells(curRow, 2) = DateSerial(it.submatches(3), it.submatches(2), it.submatches(1))
.Cells(curRow, 3) = CDate(it.submatches(4))
.Cells(curRow, 4) = Trim(it.submatches(5))
.Cells(curRow, 5) = Trim(it.submatches(6))
.Cells(curRow, 6) = Trim(it.submatches(7))
.Cells(curRow, 7) = Trim(it.submatches(8))
.Cells(curRow, 8) = Trim(it.submatches(9))
Next
End With
End If
Next
With ws
.[B:B].NumberFormatLocal = "dd/mm/yyyy"
.[C:C].NumberFormatLocal = "hh:mm:ss"
.UsedRange.EntireColumn.AutoFit
End With
MsgBox "Finish"
End Sub
複製代碼
作者:
mrkacs
時間:
2018-6-27 00:22
回復
2#
stillfish00
非常感謝 stillfish00 的幫忙
但在這先道個歉 我上傳的檔案格式有點誤差
後來這份檔案我嘗試修改內容 但是執行程式碼得不到任何資料
能請您再幫忙修改一下嗎?
附件如下
[attach]28893[/attach]
作者:
stillfish00
時間:
2018-6-27 10:41
回復
3#
mrkacs
Sub Example()
Dim sPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "請選擇資料夾"
If .Show = -1 Then
If .SelectedItems.Count > 0 Then sPath = .SelectedItems(1) Else Exit Sub
End If
End With
Dim oReg As Object: Set oReg = CreateObject("vbscript.regexp")
With oReg
.MultiLine = True
.Global = True
.Pattern = "^\s*(\S{1,10}) (\d{2})/(\d{2})/(\d{4}) (\d{2}:\d{2}:\d{2}) (.{15}) (.{10}) (.{10}) (.{7}) (.{13}) (.{12}) (.{11}) (.*)\r\n(.*)\r\n"
End With
Dim ws As Worksheet
Set ws = Workbooks.Add.Sheets(1)
Const ForReading = 1
Dim oFSO As Object: Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim oTF, oFD, sText
Dim curRow As Long
Dim match
Set oFD = oFSO.getfolder(sPath)
For Each f In oFD.Files
If oFSO.getextensionname(f.Path) = "csv" Then
Set oTF = oFSO.OpenTextFile(f.Path, ForReading)
sText = oTF.ReadAll
Set match = oReg.Execute(sText)
With ws
For Each it In match
curRow = curRow + 1
.Cells(curRow, 1) = Trim(it.submatches(0))
.Cells(curRow, 2) = DateSerial(it.submatches(3), it.submatches(2), it.submatches(1))
.Cells(curRow, 3) = CDate(it.submatches(4))
For j = 4 To 7
.Cells(curRow, j) = Trim(it.submatches(j + 1))
Next
.Cells(curRow, 8) = CDate(it.submatches(9))
.Cells(curRow, 9) = CDate(it.submatches(10))
.Cells(curRow, 10) = CDate(it.submatches(11))
.Cells(curRow, 11) = Trim(it.submatches(12))
.Cells(curRow, 12) = Trim(it.submatches(13))
Next
End With
End If
Next
With ws
.[B:B].NumberFormatLocal = "dd/mm/yyyy"
.[C:C,H:J].NumberFormatLocal = "hh:mm:ss"
.UsedRange.EntireColumn.AutoFit
End With
MsgBox "Finish"
End Sub
複製代碼
作者:
mrkacs
時間:
2018-7-1 23:14
回復
4#
stillfish00
非常感謝您的幫忙，程式執行的很順利
歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)
