あたらしいVBAプログラムをシェアします

Option Explicit

Sub ParseTextToExcel()
    Dim currentSheet As Worksheet
    Dim sectionName As String, rowNum As Long
    Dim regex As Object, isTableMode As Boolean
    Dim headers() As String, allLines() As String
    Dim filePath As String, fileContent As String
    Dim line As Variant
    
    ' 正規表現初期化（日本語ヘッダー用）
    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .Pattern = "^====\s*(.*)\s*====$"
        .Global = True
        .IgnoreCase = False
    End With
    
    ' ファイル選択ダイアログ
    filePath = Application.GetOpenFilename("テキストファイル (*.txt), *.txt", , "UTF-8ファイルを選択")
    If filePath = "False" Then Exit Sub
    
    ' UTF-8ファイル読み込み
    fileContent = ReadUTF8File(filePath)
    allLines = Split(fileContent, vbCrLf)
    
    Application.ScreenUpdating = False
    On Error GoTo ErrorHandler
    
    ' 行ごとに処理
    For Each line In allLines
        line = Trim(line)
        
        ' セクションヘッダー検出
        If regex.Test(line) Then
            sectionName = regex.Execute(line)(0).SubMatches(0)
            sectionName = CleanSheetName(sectionName)
            
            ' ワークシート作成/選択
            If Not SheetExists(sectionName) Then
                Set currentSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                currentSheet.name = sectionName
                currentSheet.Range("A1").Activate
            Else
                Set currentSheet = Worksheets(sectionName)
            End If
            
            rowNum = 1
            isTableMode = False
            Erase headers
        ElseIf Not currentSheet Is Nothing And Len(line) > 0 Then
            ' テーブルモード判定
            If Not isTableMode Then
                Dim testArr() As String
                testArr = SplitMultiSpace(line)
                If UBound(testArr) >= 2 Then
                    isTableMode = True
                    headers = testArr
                    WriteToSheet currentSheet, headers, rowNum, True
                    rowNum = rowNum + 1
                    GoTo NextLine
                End If
            End If
            
            ' データ書き込み処理
            If isTableMode Then
                Dim dataArr() As String
                dataArr = SplitMultiSpace(line)
                WriteToSheet currentSheet, dataArr, rowNum, False
                rowNum = rowNum + 1
            Else
                Dim sepPos As Long
                sepPos = InStr(line, ":")
                If sepPos > 0 Then
                    currentSheet.Cells(rowNum, 1).Value = Left(line, sepPos - 1)
                    currentSheet.Cells(rowNum, 2).Value = Trim(Mid(line, sepPos + 1))
                Else
                    currentSheet.Cells(rowNum, 1).Value = line
                End If
                rowNum = rowNum + 1
            End If
        End If
NextLine:
    Next line
    
    ' 後処理
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Sheet1").Delete
    Application.DisplayAlerts = True
    
Cleanup:
    Set regex = Nothing
    Application.ScreenUpdating = True
    Exit Sub
    
ErrorHandler:
    MsgBox "エラー発生：" & vbCrLf & _
           "ファイル: " & filePath & vbCrLf & _
           "行内容: " & line & vbCrLf & _
           "詳細: " & Err.Description, vbCritical
    Resume Cleanup
End Sub

' UTF-8ファイル読み込み関数
Private Function ReadUTF8File(ByVal filePath As String) As String
    Dim adoStream As Object
    Set adoStream = CreateObject("ADODB.Stream")
    
    With adoStream
        .Type = 2  ' adTypeText
        .Charset = "utf-8"
        .Open
        .LoadFromFile filePath
        ReadUTF8File = .ReadText(-1)  ' 全テキスト読み込み
        .Close
    End With
End Function

' 複数スペース分割関数（全角対応）
Private Function SplitMultiSpace(ByVal str As String) As String()
    Static regex As Object
    If regex Is Nothing Then
        Set regex = CreateObject("VBScript.RegExp")
        regex.Pattern = "[\s　]+"  ' 半角・全角スペース
        regex.Global = True
    End If
    
    Dim cleanedStr As String
    cleanedStr = regex.Replace(Trim(str), " ")
    SplitMultiSpace = Split(cleanedStr, " ")
End Function

' シート書き込み処理
Private Sub WriteToSheet( _
    ByVal ws As Worksheet, _
    ByRef arr() As String, _
    ByVal rowNum As Long, _
    ByVal isHeader As Boolean)
    
    Dim i As Long
    For i = 0 To UBound(arr)
        With ws.Cells(rowNum, i + 1)
            .Value = arr(i)
            If isHeader Then
                .Font.Bold = True
                .Interior.Color = RGB(221, 235, 247)
                .HorizontalAlignment = xlCenter
            End If
        End With
    Next
    
    If isHeader Then
        ws.Rows(rowNum).AutoFilter
        ws.Columns.AutoFit
    End If
End Sub

' シート名クリーニング
Private Function CleanSheetName(ByVal name As String) As String
    Dim illegalChars As Variant
    illegalChars = Array("\", "/", "?", "*", "[", "]", ":", "'")
    
    Dim c As Variant
    For Each c In illegalChars
        name = Replace(name, c, "_")
    Next
    CleanSheetName = Left(Trim(name), 31)
End Function

' シート存在確認
Private Function SheetExists(ByVal sName As String) As Boolean
    On Error Resume Next
    SheetExists = Not Worksheets(sName) Is Nothing
    On Error GoTo 0
End Function