あたらしい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