返回列表 上一主題 發帖

[發問] 代碼分析求助

mrkacs

帖子
3 
主題
1 
精華
0 
積分
54 
點名
0  
作業系統
XP 
軟體版本
4.1 
閱讀權限
20 
註冊時間
2013-8-18 
最後登錄
2023-5-16 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2018-6-24 00:28 | 只看該作者

[發問] 代碼分析求助

sample.rar (18.17 KB)



能否請各位先進幫忙VB一下

1.匯入某指定資料夾所有*.txt 檔案

2.在新分頁祇顯示前綴有數字代碼之字串，不顯示無數字代碼字串(如紅色mark所示)

3.將有數字代碼下行狀況字串移到 前列代碼之後

4.將字串分割為不同欄位 如數字字串為A1 日期字串為 B1 時間字串為 C1

在新手面前感覺有點困難，望高手能幫忙 感激不盡
收藏 分享

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
2#
發表於 2018-6-26 10:44 | 只看該作者
回復 1# mrkacs
  1. Sub Example()
  2.     Dim sPath As String
  3.     With Application.FileDialog(msoFileDialogFolderPicker)
  4.         .Title = "請選擇資料夾"
  5.         If .Show = -1 Then
  6.             If .SelectedItems.Count > 0 Then sPath = .SelectedItems(1) Else Exit Sub
  7.         End If
  8.     End With
  9.    
  10.     Dim oReg As Object: Set oReg = CreateObject("vbscript.regexp")
  11.     With oReg
  12.         .MultiLine = True
  13.         .Global = True
  14.         .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"
  15.     End With
  16.    
  17.     Dim ws As Worksheet
  18.     Set ws = Workbooks.Add.Sheets(1)
  19.    
  20.     Const ForReading = 1
  21.     Dim oFSO As Object: Set oFSO = CreateObject("Scripting.FileSystemObject")
  22.     Dim oTF, oFD, sText
  23.     Dim curRow As Long
  24.     Dim match
  25.     Set oFD = oFSO.getfolder(sPath)
  26.     For Each f In oFD.Files
  27.         If oFSO.getextensionname(f.Path) = "txt" Then
  28.             Set oTF = oFSO.OpenTextFile(f.Path, ForReading)
  29.             sText = oTF.ReadAll
  30.             Set match = oReg.Execute(sText)
  31.             With ws
  32.                 For Each it In match
  33.                     curRow = curRow + 1
  34.                     .Cells(curRow, 1) = Trim(it.submatches(0))
  35.                     .Cells(curRow, 2) = DateSerial(it.submatches(3), it.submatches(2), it.submatches(1))
  36.                     .Cells(curRow, 3) = CDate(it.submatches(4))
  37.                     .Cells(curRow, 4) = Trim(it.submatches(5))
  38.                     .Cells(curRow, 5) = Trim(it.submatches(6))
  39.                     .Cells(curRow, 6) = Trim(it.submatches(7))
  40.                     .Cells(curRow, 7) = Trim(it.submatches(8))
  41.                     .Cells(curRow, 8) = Trim(it.submatches(9))
  42.                 Next
  43.             End With
  44.         End If
  45.     Next
  46.     With ws
  47.         .[B:B].NumberFormatLocal = "dd/mm/yyyy"
  48.         .[C:C].NumberFormatLocal = "hh:mm:ss"
  49.         .UsedRange.EntireColumn.AutoFit
  50.     End With
  51.     MsgBox "Finish"
  52. End Sub
複製代碼
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

mrkacs

帖子
3 
主題
1 
精華
0 
積分
54 
點名
0  
作業系統
XP 
軟體版本
4.1 
閱讀權限
20 
註冊時間
2013-8-18 
最後登錄
2023-5-16 
3#
發表於 2018-6-27 00:22 | 只看該作者
回復 2# stillfish00


非常感謝 stillfish00  的幫忙

但在這先道個歉 我上傳的檔案格式有點誤差

後來這份檔案我嘗試修改內容 但是執行程式碼得不到任何資料

能請您再幫忙修改一下嗎?

附件如下

999.rar (2.25 KB)

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
4#
發表於 2018-6-27 10:41 | 只看該作者
回復 3# mrkacs
  1. Sub Example()
  2.     Dim sPath As String
  3.     With Application.FileDialog(msoFileDialogFolderPicker)
  4.         .Title = "請選擇資料夾"
  5.         If .Show = -1 Then
  6.             If .SelectedItems.Count > 0 Then sPath = .SelectedItems(1) Else Exit Sub
  7.         End If
  8.     End With
  9.    
  10.     Dim oReg As Object: Set oReg = CreateObject("vbscript.regexp")
  11.     With oReg
  12.         .MultiLine = True
  13.         .Global = True
  14.         .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"
  15.     End With
  16.    
  17.     Dim ws As Worksheet
  18.     Set ws = Workbooks.Add.Sheets(1)
  19.    
  20.     Const ForReading = 1
  21.     Dim oFSO As Object: Set oFSO = CreateObject("Scripting.FileSystemObject")
  22.     Dim oTF, oFD, sText
  23.     Dim curRow As Long
  24.     Dim match
  25.     Set oFD = oFSO.getfolder(sPath)
  26.     For Each f In oFD.Files
  27.         If oFSO.getextensionname(f.Path) = "csv" Then
  28.             Set oTF = oFSO.OpenTextFile(f.Path, ForReading)
  29.             sText = oTF.ReadAll
  30.             Set match = oReg.Execute(sText)
  31.             With ws
  32.                 For Each it In match
  33.                     curRow = curRow + 1
  34.                     .Cells(curRow, 1) = Trim(it.submatches(0))
  35.                     .Cells(curRow, 2) = DateSerial(it.submatches(3), it.submatches(2), it.submatches(1))
  36.                     .Cells(curRow, 3) = CDate(it.submatches(4))
  37.                     For j = 4 To 7
  38.                         .Cells(curRow, j) = Trim(it.submatches(j + 1))
  39.                     Next
  40.                     .Cells(curRow, 8) = CDate(it.submatches(9))
  41.                     .Cells(curRow, 9) = CDate(it.submatches(10))
  42.                     .Cells(curRow, 10) = CDate(it.submatches(11))
  43.                     .Cells(curRow, 11) = Trim(it.submatches(12))
  44.                     .Cells(curRow, 12) = Trim(it.submatches(13))
  45.                 Next
  46.             End With
  47.         End If
  48.     Next
  49.     With ws
  50.         .[B:B].NumberFormatLocal = "dd/mm/yyyy"
  51.         .[C:C,H:J].NumberFormatLocal = "hh:mm:ss"
  52.         .UsedRange.EntireColumn.AutoFit
  53.     End With
  54.     MsgBox "Finish"
  55. End Sub
複製代碼
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

mrkacs

帖子
3 
主題
1 
精華
0 
積分
54 
點名
0  
作業系統
XP 
軟體版本
4.1 
閱讀權限
20 
註冊時間
2013-8-18 
最後登錄
2023-5-16 
5#
發表於 2018-7-1 23:14 | 只看該作者
回復 4# stillfish00


    非常感謝您的幫忙，程式執行的很順利

TOP

        靜思自在 : 吃苦了苦、苦盡廿來，享福了福、福盡悲來。
返回列表 上一主題