採番チェック

Sub ValidateItemNumbers()
    Dim ws As Worksheet
    Set ws = ActiveSheet ' 現在アクティブなシートを使用

    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' A列で最後の行を取得

    Dim re As Object
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "(\d+(-\d+)*)\."
    re.Global = False

    Dim currentNums() As Long
    ReDim currentNums(1 To 10) ' 仮に階層は10までとする
    Dim i As Long, j As Long
    Dim isValid As Boolean
    isValid = True ' バリデーションの結果を保持するフラグ

    For i = 1 To lastRow
        Dim cellValue As String
        cellValue = Trim(ws.Cells(i, 1).Text)

        If re.Test(cellValue) Then
            Dim match As Object
            Set match = re.Execute(cellValue)

            ' マッチしたパターンを即時ウィンドウに表示
            Debug.Print match(0).Value

            Dim parts() As String
            parts = Split(match(0).SubMatches(0), "-")
            Dim levels As Integer
            levels = UBound(parts) + 1

            ' 階層毎に数値を検証
            For j = 1 To levels
                Dim partNum As Long
                partNum = Val(parts(j - 1))

                ' 数値が期待されるシーケンスと一致しない場合
                If currentNums(j) + 1 <> partNum Then
                    ws.Cells(i, 1).Interior.Color = RGB(255, 0, 0) ' セルの色を赤に変更
                    isValid = False
                    Exit For
                Else
                    currentNums(j) = partNum ' 現在の数値を更新
                End If
            Next j

            ' 現在のレベルより深いレベルの数値をリセット
            For j = levels + 1 To UBound(currentNums)
                currentNums(j) = 0
            Next j
        End If
    Next i

    If isValid Then
        MsgBox "全ての項番が正しく採番されています。", vbInformation
    Else
        MsgBox "いくつかの項番が正しく採番されていません。赤く塗られたセルを確認してください。", vbExclamation
    End If
End Sub

Sub ValidateItemNumbers()
    Dim ws As Worksheet
    Set ws = ActiveSheet ' 現在アクティブなシートを使用

    Dim lastRow As Long, lastCol As Long
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' A列で最後の行を取得
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column ' 1行目で最後の列を取得

    Dim re As Object
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "(\d+(-\d+)*)\.|．"
    re.Global = False

    Dim currentNums() As Long
    ReDim currentNums(1 To 10) ' 仮に階層は10までとする
    Dim i As Long, j As Long, col As Long
    Dim isValid As Boolean
    isValid = True ' バリデーションの結果を保持するフラグ

    For i = 1 To lastRow
        For col = 1 To lastCol ' 各列をループ
            Dim cellValue As String
            cellValue = Trim(ws.Cells(i, col).Text)

            If cellValue <> "" And re.Test(cellValue) Then ' セルが空白でなく、正規表現に一致する場合
                Dim match As Object
                Set match = re.Execute(cellValue)

                ' マッチしたパターンを即時ウィンドウに表示
                Debug.Print match(0).Value

                Dim parts() As String
                parts = Split(match(0).SubMatches(0), "-")
                Dim levels As Integer
                levels = UBound(parts) + 1

                ' 階層毎に数値を検証
                For j = 1 To levels
                    Dim partNum As Long
                    partNum = Val(parts(j - 1))

                    ' 数値が期待されるシーケンスと一致しない場合
                    If currentNums(j) + 1 <> partNum Then
                        ws.Cells(i, col).Interior.Color = RGB(255, 0, 0) ' セルの色を赤に変更
                        isValid = False
                        Exit For
                    Else
                        currentNums(j) = partNum ' 現在の数値を更新
                    End If
                Next j

                ' 現在のレベルより深いレベルの数値をリセット
                For j = levels + 1 To UBound(currentNums)
                    currentNums(j) = 0
                Next j

                Exit For ' 同じ行に項番が複数存在しないため、次の行に移動
            End If
        Next col
    Next i

    If isValid Then
        MsgBox "全ての項番が正しく採番されています。", vbInformation
    Else
        MsgBox "いくつかの項番が正しく採番されていません。赤く塗られたセルを確認してください。", vbExclamation
    End If
End Sub