ある表を決められたルールで並び替え　④ 決められた行に空白行を挿入するには

先日からの「並び替えに関する課題」について、少しずつ進めている。
昨日は、書き出したコードを、並び替え順を表す数字に置き換えてみた。
infoment.hatenablog.com

今日はさらに、決められた行に空白行を挿入してみる。
f:id:Infoment:20200219215710j:plain

と言っても、実際に空白行を挿入するのは面倒だ。
そこで、表の下に沢山転がっている空白行を利用する。
昨日の時点で ↓ こうだったものが、
f:id:Infoment:20200218215839p:plain

仮にこうなれば、
f:id:Infoment:20200219220029p:plain

Ｅ列で並び替えると、↓ こうなる。
f:id:Infoment:20200219220125p:plain

後で空白行を挿入する場合と、結果は同じだ。
そこでまず、コードと順位の対照表を更新する。
f:id:Infoment:20200219220252p:plain

後は、空白行の順位を追記して、並び替え。
最後に並び替え用の列を削除して、完成だ。

Sub 並べ替え()
    ' 元データ保護のため、シートごとコピーして並べ替え。
    Dim Sh As Worksheet
        ActiveSheet.Copy After:=ActiveSheet
    Set Sh = ActiveSheet
        Sh.Name = "並べ替え後"
        
    ' 正規表現。
    Dim myReg As Object
    Set myReg = CreateObject("VBScript.RegExp")
    ' パターン定義。
    ' 一文字以上の英字のあとに、一回以上連続してスペースが続く。
    ' その後に英字が３文字続き、ピリオドののち、商品名となる。
    ' 今回必要なのは、英字が３文字続く部分。
        myReg.Pattern = "^[A-Z]+\s+([A-Z]{3})\..*$"
    
    ' A列をループで確認。キーとなるコードをE列に書き出す。
    Dim MC As Object ' MatchCollection
    Dim Dict As Scripting.Dictionary
    Set Dict = SortDict
    Dim r As Range
        For Each r In Range("A2:A6")
            If myReg.Test(r) Then
                Set MC = myReg.Execute(r)
                Dim temp As String
                    temp = MC(0).SubMatches(0)
                    If Dict.Exists(temp) Then
                        Cells(r.Row, "E") = Dict(temp)
                    End If
            End If
        Next
    
    ' 空白行並び替え用
    Dim arr As Variant
        arr = Array(3, 5, 6)
    
    ' 並び替え用順位の貼り付け。
        Cells(Rows.Count, "E").End(xlUp).Offset(1).Resize(UBound(arr) + 1) = _
            WorksheetFunction.Transpose(arr)
    
    ' 並び替え。
    Dim SortRange As Range
    Set SortRange = Range("A1").CurrentRegion
    
        Sh.Sort.SortFields.Clear
        Sh.Sort.SortFields.Add2 Key:=SortRange.Columns("E:E")
        With Sh.Sort
            .SetRange SortRange
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        Columns("E:E").Delete Shift:=xlToLeft
    
        Range("A1").Select
End Sub

Public Property Get SortDict() As Scripting.Dictionary
    Dim Tb As ListObject
    Set Tb = Sheets("並び順").ListObjects(1)
    
    Dim Dict As Scripting.Dictionary
    Set Dict = New Scripting.Dictionary
    
    Dim ListRow As Excel.ListRow
        For Each ListRow In Tb.ListRows
            With ListRow.Range
                Dict(.Cells(1).Value) = .Cells(2).Value
            End With
        Next
    
    Set SortDict = Dict
End Property