Grep結果をシート出力するマクロ
2020年02月29日
ファイルサイズの大きいテキストデータを扱うときにotbEditを使っている。
otbEdit（オタベエディタ）には、Grep機能があって、
特定の文字列を含む行をフォルダ内のテキストファイルから検索して一覧で出してくれる。
便利なんだけど、出力結果が扱いづらい形式で出てくるので、
エクセルに転記するマクロを作ってみた。
出力形式は以下のとおり。
ファイルフルネーム（行数）：行内容
フルネームからフォルダ名、ファイル名、拡張子に分割して、
№をつけて出力。
クリップボードから読み込みとファイルから読み込みをできるようにした。
以下、ソース。
otbEdit（オタベエディタ）には、Grep機能があって、
特定の文字列を含む行をフォルダ内のテキストファイルから検索して一覧で出してくれる。
便利なんだけど、出力結果が扱いづらい形式で出てくるので、
エクセルに転記するマクロを作ってみた。
出力形式は以下のとおり。
ファイルフルネーム（行数）：行内容
フルネームからフォルダ名、ファイル名、拡張子に分割して、
№をつけて出力。
クリップボードから読み込みとファイルから読み込みをできるようにした。
以下、ソース。
Option Explicit
Sub ◆oGrep結果の取り込み()
Dim RC As Long
RC = MsgBox("取り込み対象テキストの指定。クリップボードから取り込みますか？", vbYesNoCancel)
Dim TextBuf As String
If RC = vbCancel Then
Exit Sub
ElseIf RC = vbYes Then
TextBuf = クリップボードの値を取得 'オートフィルタ Function クリップボードの値を取得() As String
Else 'ファイルから
TextBuf = テキストファイルをバッファへ(txtファイル名取得)
End If
Dim TextArray: TextArray = Split(TextBuf, Chr(10))
Dim TextLine As String, i As Long, cnt As Long: cnt = 1
Dim cPos As Long, LPos As Long, pPos As Long, yPos As Long, yPos2 As Long
Dim Arr(): ReDim Arr(UBound(TextArray), 6)
Arr(0, 0) = "№"
Arr(0, 1) = "FullName"
Arr(0, 2) = "Folder"
Arr(0, 3) = "File"
Arr(0, 4) = "Ext"
Arr(0, 5) = "Line"
Arr(0, 6) = "Text"
For i = 1 To UBound(TextArray) - 1 '１行目は「解析中」なので無視
TextLine = TextArray(i)
If Mid(TextLine, 2, 1) = ":" Then
cPos = InStr(3, TextLine, ":")
LPos = InStrRev(Left(TextLine, cPos), "(")
pPos = InStrRev(Left(TextLine, cPos), ".")
yPos = InStrRev(Left(TextLine, cPos), "\")
yPos2 = InStrRev(Left(TextLine, yPos - 1), "\")
Arr(cnt, 0) = cnt - 0
Arr(cnt, 1) = Left(TextLine, LPos - 1)
Arr(cnt, 2) = Mid(TextLine, yPos2 + 1, yPos - yPos2 - 1)
Arr(cnt, 3) = Mid(TextLine, yPos + 1, LPos - yPos - 1)
Arr(cnt, 4) = Mid(TextLine, pPos + 1, LPos - pPos - 1) '"Ext"
Arr(cnt, 5) = Mid(TextLine, LPos + 1, cPos - LPos - 2) '"Line"
Arr(cnt, 6) = Right(TextLine, Len(TextLine) - cPos) '"Text"
cnt = cnt + 1
End If
Next i
'出力
Worksheets.Add
Call ArrayToCell_2d(Cells(1, 1), Arr)
ActiveSheet.Name = "oGrep"
End Sub
Private Function txtファイル名取得(Optional デフォルト As String = "")
If デフォルト = "" Then
デフォルト = デスクトップパス
End If
Dim i As Long
'’https://excel-ubara.com/excelvba1/EXCELVBA376.html
Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim FulName As String
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = デフォルト
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "テキストファイル", "*.txt"
.Filters.Add "すべてのファイル", "*.*"
.Title = "テキストファイルの選択"
If .Show = True Then
FulName = .SelectedItems(1)
Else
MsgBox "キャンセルしました"
End If
End With
Set FSO = Nothing
txtファイル名取得 = FulName
End Function
Function クリップボードの値を取得() As String
'クリップボードから文字列を取得
'https://www.ka-net.org/blog/?p=7537
With CreateObject("Forms.TextBox.1")
.MultiLine = True
If .CanPaste = True Then .Paste
クリップボードの値を取得 = .Text
End With
End Function
Function テキストファイルをバッファへ(FullName As String) As String
Dim buf As String
With CreateObject("Scripting.FileSystemObject")
With .GetFile(FullName).OpenAsTextStream
buf = .ReadAll
.Close
End With
End With
テキストファイルをバッファへ = buf
End Function
Sub ArrayToCell_2d(Target As Range, oArr, Optional ColCnt As Long = 0) '配列貼り付け便利モジュール
Dim iRowMax: iRowMax = UBound(oArr, 1) - LBound(oArr, 1) + 1 '// １次元目の要素数を取得 '// 二次元配列の最大行数
Dim iColMax: iColMax = UBound(oArr, 2) - LBound(oArr, 2) + 1 '// ２次元目の要素数を取得'// 二次元配列の最大列数
'// Rangeオブジェクトで開始セルから貼り付けるセル範囲を拡張する場合
If ColCnt > 0 And ColCnt <= iColMax Then
Target.Resize(iRowMax, ColCnt).Value = oArr
Else
Target.Resize(iRowMax, iColMax).Value = oArr
End If
End Sub
Private Function デスクトップパス()
Dim UserName As String
UserName = ユーザー名取得
デスクトップパス = "C:\Users\" & UserName & "\Desktop"
End Function
Private Function ユーザー名取得()
Dim WshNetworkObject As Object
Set WshNetworkObject = CreateObject("WScript.Network")
ユーザー名取得 = WshNetworkObject.UserName
Set WshNetworkObject = Nothing
End Function
PR
Comment