最近bvaやってるんだけど、そこで使えそうな関数とか生成できたら共有したい(個人アウトプット用)

' 配列を受け取り、その文字列たちを含む行とマッチする正規表現パターンを生成する
Function BuildRegexPattern(keywords As Variant) As String
    Dim pattern As String
    Dim i As Integer
    
    ' 正規表現の始まりを設定
    pattern = ".*("
    
    ' 各キーワードを正規表現パターンに追加
    For i = LBound(keywords) To UBound(keywords)
        ' 最初の要素以外の場合はパイプ(|)で区切る
        If i > LBound(keywords) Then
            pattern = pattern & "|"
        End If
        pattern = pattern & keywords(i)
    Next i
    
    ' 正規表現の終わりを設定
    pattern = pattern & ").*"
    
    ' 完成した正規表現パターンを返す
    BuildRegexPattern = pattern
End Function

Function HasPrefix(inputStr As String, targetPrefixStr As String) As Boolean
    ' 指定された文字列の先頭がターゲットプレフィックスで始まっているかを判断する
    If Len(targetPrefixStr) = 0 Then
        HasPrefix = False ' プレフィックスが空の場合はFalseを返す
        Exit Function
    End If
    
    If Left(inputStr, Len(targetPrefixStr)) = targetPrefixStr Then
        HasPrefix = True ' プレフィックスが一致する場合はTrueを返す
    Else
        HasPrefix = False ' 一致しない場合はFalseを返す
    End If
End Function

Sub onButtonClicked()
    Dim folderPath As String
    Dim filenamePrefix As String: filenamePrefix = "選別後_"
    Dim targetExtension As String: targetExtension = "log"
    Dim charset As String: charset = "utf-8"
    folderPath = InputFolderAsFolderPath()
    If folderPath = "" Then Exit Sub

    Call ConvertLogFiles(folderPath, filenamePrefix, targetExtension, charset)
    MsgBox "処理完了"
End Sub

Sub ConvertLogFiles(inputFolderPath As String, filenamePrefix As String, targetExtension As String, charset As String)
    Dim file As Object
    Dim logFiles As Collection
    Dim newFileName As String
    Dim fileContent As String
    Dim newFileContent As String

    ' フォルダ内のファイルを取得
    Set logFiles = ExtractFileFromFolder(inputFolderPath, targetExtension)

    ' 取得したファイルに対して処理を実行
    For Each file In logFiles
        ' ファイルを読み込む
        fileContent = ReadFileContent(file.Path, charset)

        ' 正規表現置換処理
        newFileContent = RegexReplace(fileContent, "^(?=\d)(\d{4})-(\d{2})-(\d{2})\b", "$1/$2/$3") ' YYYY-MM-DD を YYYY/MM/DD に変換
        newFileContent = RegexReplace(newFileContent, "^(?!\d{4}/\d{2}/\d{2}).*$", "") ' 行頭が日付以外の行を削除
        newFileContent = RegexReplace(newFileContent, "^\n", "") ' 空行（行頭に改行文字がある行）を削除

        ' 新しいファイル名を作成
        newFileName = RemovePeriod(file.Name)
        newFileName = inputFolderPath & "\" & filenamePrefix & newFileName & "." & targetExtension

        ' 作成ファイルを出力
        WriteFileContent newFileName, newFileContent, charset
    Next file
End Sub

' フォルダ内の指定拡張子のファイルを取得
Function ExtractFileFromFolder(inputFolderPath As String, targetExtension As String) As Collection
    Dim file As Object
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim logFiles As Collection: Set logFiles = New Collection ' .logファイルを格納するコレクションを初期化
    Dim inputFolder As Object: Set inputFolder = fso.GetFolder(inputFolderPath) ' 入力フォルダを取得

    For Each file In inputFolder.Files
        ' 指定した拡張子のファイルを収集
        If LCase(fso.GetExtensionName(file.Name)) = targetExtension Then
            logFiles.Add file
        End If
    Next file
    Set ExtractFileFromFolder = logFiles
End Function

Function RemovePeriod(fileName As String) As String
    Dim newName As String
    Dim originalExtension As String
    Dim periodPosition As Integer
    
    periodPosition = InStrRev(fileName, ".") ' 拡張子の位置を取得
    originalExtension = Mid(fileName, periodPosition) ' 拡張子を取得
    
    ' "log" を削除した部分を取得
    newName = Left(fileName, periodPosition - 1)
    newName = Replace(newName, "log", "")
    
    newName = newName & originalExtension ' 新しいファイル名を生成
    
    RemovePeriod = newName
End Function

' ファイルの内容を読み込む関数
Function ReadFileContent(filePath As String, charset as String) As String
    Dim stream As Object
    Dim content As String
    
    Set stream = CreateObject("ADODB.Stream")
    stream.Type = 2 ' 2 = テキストモードで読み込み
    stream.Charset = charset
    stream.Open
    stream.LoadFromFile filePath
    content = stream.ReadText(-1) ' -1 = 読込のみ
    stream.Close
    
    Set stream = Nothing
    
    ReadFileContent = content
End Function

' 指定文字列から指定正規表現に一致する文字列を指定文字に置換する
Function RegexReplace(inputStr As String, pattern As String, replaceString As String) As String
    Dim regEx As Object: Set regEx = CreateObject("VBScript.RegExp") ' 正規表現オブジェクト
    Dim outputStr As String
    
    With regEx
        .Global = True
        .MultiLine = True ' 行ごとにマッチ
        .Pattern = pattern
    End With
    
    outputStr = regEx.Replace(inputStr, replaceString) ' 置換処理

    RegexReplace = outputStr
End Function

' ファイル名とコンテンツを組み合わせて出力
Sub WriteFileContent(filePath As String, content As String, charset as String)
    Dim stream As Object
    
    Set stream = CreateObject("ADODB.Stream")
    stream.Type = 2 ' 2 = Text
    stream.Charset = charset
    stream.Open
    stream.WriteText content
    stream.SaveToFile filePath, 2 ' 2 = 上書きモード
    stream.Close
    
    Set stream = Nothing
End Sub

' 指定エクセルの指定カラムの2行目から最終行までを読み込み、辞書を生成
Function CreateDictFromColumn(excelPath As String, column As Integer) As Object
    Dim xlApp As Object
    Dim xlWorkbook As Object
    Dim xlSheet As Object
    Dim lastRow As Long
    Dim dict As Object
    Dim key As String
    Dim value As String
    Dim i As Long
    
    ' 新しい辞書を作成する
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' Excelアプリケーションを開く
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False
    
    ' Excelファイルを開く
    Set xlWorkbook = xlApp.Workbooks.Open(excelPath)
    ' 最初のシートを取得
    Set xlSheet = xlWorkbook.Sheets(1)
    
    ' 指定された列の最終行を取得
    lastRow = xlSheet.Cells(xlSheet.Rows.Count, column).End(-4162).Row
    
    ' シートからデータを読み込み、辞書に追加する
    For i = 2 To lastRow ' 2行目から開始
        key = xlSheet.Cells(i, column).Value
        If Not dict.exists(key) Then
            ' すでに存在しない場合のみ追加
            dict.Add key, ""
        End If
    Next i
    
    ' Excelを閉じる
    xlWorkbook.Close False
    xlApp.Quit
    
    ' オブジェクトの解放
    Set xlSheet = Nothing
    Set xlWorkbook = Nothing
    Set xlApp = Nothing
    
    ' 作成した辞書を返す
    Set CreateDictFromColumn = dict
End Function

' 指定エクセルの指定カラムの2行目から最終行までを読み込み、最初の文字のみを取得した辞書を生成
Function CreateFirstCharDictFromExcel(ByVal excelFilePath As String, ByVal column As Integer) As Object
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim lastRow As Long
    Dim i As Long
    Dim key As String
    Dim dict As Object
    
    ' 辞書を作成
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' Excelアプリケーションを作成
    Set xlApp = CreateObject("Excel.Application")
    
    ' Excelファイルを開く
    Set xlBook = xlApp.Workbooks.Open(excelFilePath)
    
    ' シートを選択
    Set xlSheet = xlBook.Sheets(1) ' 1番目のシートを選択
    
    ' 指定列の最終行を取得
    lastRow = xlSheet.Cells(xlSheet.Rows.Count, column).End(-4162).Row ' xlUpの-4162
    
    ' エクセルの指定列から文字列の最初を辞書のkeyに追加
    For i = 2 To lastRow ' 2行目から最終行までループ
        key = Left(xlSheet.Cells(i, column).Value, 1) ' 文字列の最初の文字をキーにする
        If Not dict.Exists(key) Then ' キーがまだ辞書に存在しない場合のみ追加
            dict.Add key, ""
        End If
    Next i
    
    ' Excelファイルを閉じる
    xlBook.Close False
    
    ' Excelアプリケーションを終了
    xlApp.Quit
    
    ' 使用したExcelオブジェクトを解放
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    
    ' 作成した辞書を返す
    Set CreateFirstCharDictFromExcel = dict
End Function

' 指定配列の指定カラム番目の要素を詰める(引数は複数指定可)
Function RemoveColumnsFromArray(inputArr() As String, ParamArray columns() As Variant) As String()
    Dim outputArr() As String
    Dim i As Integer
    Dim j As Integer
    Dim index As Integer
    
    ' 出力配列のサイズを設定
    ReDim outputArr(LBound(inputArr) To UBound(inputArr) - UBound(columns))
    
    ' 出力配列のインデックスを設定
    index = LBound(outputArr)
    
    ' 入力配列から指定されたカラムを削除して新しい配列を作成
    For i = LBound(inputArr) To UBound(inputArr)
        Dim isToRemove As Boolean
        isToRemove = False
        ' 削除対象のカラムかどうかをチェックする
        For j = LBound(columns) To UBound(columns)
            If i = columns(j) Then
                isToRemove = True
                Exit For
            End If
        Next j
        ' 削除対象でない場合、要素を出力配列にコピーする
        If Not isToRemove Then
            outputArr(index) = inputArr(i)
            index = index + 1
        End If
    Next i
    
    ' 出力配列を返す
    RemoveColumnsFromArray = outputArr
End Function

Function RemoveAfterParen(inputStr As String) As String
    Dim parenIndex As Integer
    
    ' 最初の '(' を検索する
    parenIndex = InStr(inputStr, "(")
    
    ' '(' が見つかった場合
    If parenIndex > 0 Then
        ' '(' 以降の部分を削除して残りを返す
        RemoveAfterParen = Left(inputStr, parenIndex - 1)
    End If
    ' '(' が見つからない場合は、元の文字列をそのまま返す
    RemoveAfterParen = inputStr
End Function

' UTF-8のCSVを読み取り、一行ずつ配列に読み込む
Function ConvCSVToArray(ByVal filePath As String) As Variant
    Dim Stream As Object
    Dim fileContent As String
    
    ' ADODB.Streamオブジェクトを作成し、設定する
    Set Stream = CreateObject("ADODB.Stream")
    With Stream
        .Charset = "UTF-8"      ' 文字セットをUTF-8に設定する
        .Open                       ' ストリームを開く
        .LoadFromFile filePath     ' ファイルを読み込む
        fileContent = .ReadText    ' テキストを読み込んで変数fileContentに格納する
        .Close                      ' ストリームを閉じる
    End With
    
    ' 改行文字(vbLf)で文字列を分割し、配列に格納して返す
    ConvCSVToArray = Split(fileContent, vbLf)
End Function

Sub AppendToFile(outputFilePath As String, appendedStr As String)
    Dim stream As Object
    
    ' ADODB.Streamオブジェクトを作成する
    Set stream = CreateObject("ADODB.Stream")
    
    ' ストリームをUTF-8で初期化し、追記モードで開く
    stream.Type = 2 ' テキストモード
    stream.Charset = "UTF-8" ' UTF-8エンコーディング
    stream.Open
    
    ' ファイルを読み込んでストリームにロードする
    stream.LoadFromFile outputFilePath
    
    ' ストリームの位置をファイルの末尾に設定する
    stream.Position = stream.Size
    
    ' テキストをUTF-8で書き込む（追記）
    stream.WriteText appendedStr, 1 ' 追記モード
    
    ' ストリームをファイルに保存して閉じる
    stream.SaveToFile outputFilePath, 2 ' 上書き保存
    stream.Close
End Sub

フォルダを選択するダイアログを表示する関数
この関数はユーザーにフォルダ選択ダイアログを表示し、選択されたフォルダのパスを返します。

Function SelectFolder() As String
    Dim folderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "フォルダを選択してください"
        .AllowMultiSelect = False
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
            SelectFolder = folderPath
        Else
            MsgBox "フォルダが選択されませんでした。"
            SelectFolder = ""
        End If
    End With
End Function

VBAでは直接ファイルから文字コードを自動的に判断する標準機能は提供されていません。ただし、外部ライブラリやツールを利用する方法もありますが、それを使わずに一部の基本的な判定（例えばBOM（Byte Order Mark）の有無によるUTF-8の判断）を行うことは可能です。ここでは、ファイルがUTF-8（BOMあり）であれば0、それ以外（ここではSJISと仮定）であれば1を返す基本的な例を紹介します。

' 指定ファイルパスの文字コードからCharsetを取得
Function getCharsetMode(filePath As String) As Integer
    Dim fileNo As Integer
    Dim firstBytes As String
    Dim charsetMode As Integer
    
    fileNo = FreeFile()
    Open filePath For Binary As #fileNo
    
    ' 最初の3バイトを読み込む
    firstBytes = String(3, 0)
    Get #fileNo, , firstBytes
    Close #fileNo
    
    ' UTF-8のBOMはEF BB BF
    If AscB(MidB(firstBytes, 1, 1)) = &HEF And _
       AscB(MidB(firstBytes, 2, 1)) = &HBB And _
       AscB(MidB(firstBytes, 3, 1)) = &HBF Then
        charsetMode = 0  ' UTF-8 (BOMあり)
    Else
        charsetMode = 1  ' SJIS（仮定）
    End If
    
    getCharsetMode = charsetMode
End Function

与えられた配列の各要素を空白で区切って一つの文字列に結合する関数を作成できます。以下はその例です：

' 配列を空白区切りの文字列に変換する
Function JoinArrayToStr(arr() As String) As String
    Dim resultStr As String
    Dim i As Integer
    
    ' 結果を初期化
    resultStr = ""
    
    ' 配列の各要素を空白で区切って結合する
    For i = LBound(arr) To UBound(arr)
        If i = LBound(arr) Then
            ' 最初の要素の場合は空白を追加せずに要素を追加する
            resultStr = arr(i)
        Else
            ' 2番目以降の要素の場合は空白を追加してから要素を追加する
            resultStr = resultStr & " " & arr(i)
        End If
    Next i
    
    ' 結果を返す
    JoinArrayToStr = resultStr
End Function

' 文字列が()を含むか確認する
Function HasParentheses(inputString As String) As Boolean
    ' 文字列に左括弧と右括弧が含まれているかを確認する
    HasParentheses = InStr(inputString, "(") > 0 And InStr(inputString, ")") > 0
End Function

' ()でくくられた文字列部分を削除する
Function RemoveParentheses(inputString As String) As String
    Dim openParenIndex As Integer
    Dim closeParenIndex As Integer
    Dim resultString As String
    
    ' 文字列に括弧が含まれているかを確認する
    If HasParentheses(inputString) Then
        ' 左括弧のインデックスを検索する
        openParenIndex = InStr(inputString, "(")
        
        ' 右括弧のインデックスを検索する
        closeParenIndex = InStr(openParenIndex, inputString, ")")
        
        ' 括弧とその内側の文字列を削除する
        resultString = Left(inputString, openParenIndex - 1) & Mid(inputString, closeParenIndex + 1)
    Else
        ' 括弧が含まれていない場合は、元の文字列を返す
        resultString = inputString
    End If
    
    RemoveParentheses = resultString
End Function

' inputStrが"http"から始まる場合にTrueを返す
Function IsStartHttp(inputStr As String) As Boolean
    IsStartHttp = Left(inputStr, 4) = "http"
End Function

' inputStrの後ろから二つ目の'/'から後ろまでの文字列を'_'区切りにして返す
Function ExtractString(inputStr As String) As String
    Dim segments() As String
    Dim outputStr As String
    Dim i As Integer

    ' 最後の文字がスラッシュの場合は削除
    If Right(inputStr, 1) = "/" Then
        inputStr = Left(inputStr, Len(inputStr) - 1)
    End If
    
    ' '/' で文字列を分割して配列に格納する
    segments = Split(inputStr, "/")
    
    ' 配列の後ろから2番目の要素から最後までを抜き取る
    outputStr = ""
    For i = UBound(segments) - 1 To UBound(segments)
        If outputStr <> "" Then
            outputStr = outputStr & "_"
        End If
        outputStr = outputStr & segments(i)
    Next i
    
    ' 結果を返す
    ExtractAndJoin = outputStr
End Function

' 開始時刻と終了時刻を引数として受け取り、その差を計算して実行時間を求めます
Function CalculateExecutionTime(startTime As Double, endTime As Double) As String
    Dim executionTime As Double
    Dim hours As Integer
    Dim minutes As Integer
    
    ' 実行時間を計算する（秒単位）
    executionTime = endTime - startTime
    
    ' 実行時間を時と分に変換する
    hours = Int(executionTime / 3600)
    minutes = Int((executionTime - (hours * 3600)) / 60)
    
    ' 実行時間を文字列形式で返す（HH:MM 形式）
    CalculateExecutionTime = Format(hours, "00") & ":" & Format(minutes, "00")
End Function

Function HasFrontParen(inputStr As String) As Boolean
    ' '(' が存在し、かつ ')' が存在しない場合に True を返す
    If InStr(inputStr, "(") > 0 And InStr(inputStr, ")") = 0 Then
        HasFrontParen = True
    Else
        HasFrontParen = False
    End If
End Function

カレントディレクトリの.txtから.logを作成

@echo off
for %%f in (*.txt) do (
    set filename=%%~nf
    echo Processing %%f...
    echo Creating %%filename%.log...
    (
        for /F "tokens=*" %%l in (%%f) do (
            echo %%l>>"%%filename%.log"
        )
    )
)
echo Process completed.
pause