シリアルって、入力ミスは起きないですか？

・の場合は１つなので、ミスられてもプログラム側は、知ーらないと言えますが、

-の場合は連番なので、そうも言ってられない気がするんですが・・

例えば、
TT112-TT115 が正しいのに、
TT112-TT15  と入れて、マイナスになったり、、
TT112-TT1115と入れて、飛んでもない連番になったりした時、
それくらいプログラムの方でチェックしてよ、ってな要求が出ませんかね？

あと、いつもアルファベット+連番 の形になっているんですか？
アルファベット+連番+アルファベット とかの形もあったりするんですか？

いま気付いたのですが、個数とシリアルは合致すべきなんですね？

もし、どっちかを入力ミスして、合致しなかったらどう処理しますか？

それとも、間違えっこないので、そんなこと考えなくていいですか？

個数とシリアルの数が合致しないときは、メッセージを出すことにします。

Sub AutoAssignment()
    Dim aCell As Range, brk, Serial, i As Long, k As Long, preSt As String
    Dim regE As Object, dicT As Object, St, Ed, Itm, Rw As Long, msg As String
    
    Worksheets("Sheet2").UsedRange.ClearContents
    
    With Worksheets("Sheet2")
        Worksheets("Sheet1").Range("A1").CurrentRegion.Copy
        .Range("A1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
        
        Set dicT = CreateObject("Scripting.Dictionary")
        Set regE = CreateObject("VBScript.RegExp")
        regE.Pattern = "[0-9]+$"
        regE.Global = True
        
        For Each aCell In .Range("B5", .Cells(5, .Columns.Count).End(xlToLeft))
            
            If aCell <> "" Then
                brk = Split(aCell & "・", "・")
                
                For i = 0 To UBound(brk) - 1
                    If brk(i) <> "" Then
                        If brk(i) Like "*-*" Then
                            Serial = Split(brk(i), "-")
                            St = regE.Execute(Serial(0))(0)
                            Ed = regE.Execute(Serial(1))(0)
                            
                            preSt = Left(Serial(0), Len(Serial(0)) - Len(St))
                            
                            If CLng(St) > CLng(Ed) Then
                                Rw = Rw + 1
                                dicT(Rw) = brk(i) & Chr(10) & "は番号が逆です"
                            Else
                                For k = St To Ed
                                    Rw = Rw + 1
                                    dicT(Rw) = preSt & Format(k, String(Len(St), "0"))
                                Next k
                            End If
                        Else
                            Rw = Rw + 1
                            dicT(Rw) = brk(i)
                        End If
                    End If
                Next i
                
                Itm = dicT.items
                .Cells(5, aCell.Column).Resize(dicT.Count) = Application.Transpose(Itm)
                
                If dicT.Count <> aCell.Offset(-1) Then
                    msg = msg & Split(aCell.Address(1, 0), "$")(0) & "列、"
                End If
                
                dicT.RemoveAll
                Rw = 0
            End If
        Next aCell
        
        If msg <> "" Then
            MsgBox "個数不一致列" & Chr(10) & Left(msg, Len(msg) - 1)
        End If
        
        .Select
    End With
End Sub


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他