セル範囲内の空白行や結合にも対応したSortオブジェクトVBA

'並び替えデータエリア把握

Function STRC() As Range

        ErEnd = False
        
        Set STRC = Nothing
        On Error Resume Next
        Set STRC = Application.InputBox("見出し行も含めて並び替え" & _
            "ブロックで" & vbCrLf & "始点となるセルを指定して" & _
            "ください。", Title:="始まりのセル指定", Type:=8)
        If Not STRC Is Nothing Then
            STRC.Activate
        End If
        If Err.Number > 0 Then
            MsgBox "キャンセルされました。終了します。"
            ErEnd = True
        Exit Function
        End If
        On Error GoTo 0
        STRCr = STRC.Row
        STRCc = STRC.Column
        If Application.Intersect(ADRange, STRC) Is Nothing Then
            MsgBox "シートのデータ範囲外のセルを指定しました。" _
                & vbCrLf & "再指定してください。", _
                vbExclamation, "再指定"
            ErEnd = True
            Exit Function
        End If
End Function

Function SortAreaA() As Range
        On Error Resume Next
        Set SortAreaA = STRC.CurrentRegion
        If ErEnd = True Then
            MsgBox "この操作は、条件設定の不備により実行されません。"
            Exit Function
        End If
        SortAreaA.Select
        On Error GoTo 0
End Function

Function SortAreaB() As Range
    Dim SortAreaAn, LDB, LDBR As Range
    Dim LDBEr, LDBEc As Long
        On Error Resume Next
        Set LDB = Application.InputBox("並び替えする最後尾のデータ" & _
            "ブロック内で、" & vbCrLf & "いずれかのセルをクリック" & _
            "してください。" & vbCrLf & "セル位置に基づいて検索" & _
            "エリアをセットします。" & vbCrLf & " " & vbCrLf & _
            "セルを置き直しする場合は「キャンセル」を選択してくだ" & _
            "さい。", Title:="最後尾データブロックの指定", Type:=8)
        If Not LDB Is Nothing Then
            LDB.Activate
        End If
        If Err.Number > 0 Then
            MsgBox "キャンセルされました。終了します。"
            ErEnd = True
            Exit Function
        End If
        On Error GoTo 0
        Set LDBR = LDB.CurrentRegion
        LDBEr = LDBR.Row + LDBR.CurrentRegion.Rows.Count - 1
        LDBEc = LDBR.Column + LDBR.CurrentRegion.Columns.Count - 1
        If Application.Intersect(ADRange, LDBR) Is Nothing Then
           MsgBox "シートのデータ範囲外のセルを指定しました。" _
                    & vbCrLf & "再指定してください。", _
                    vbExclamation, "再指定"
           ErEnd = True
           Exit Function
        End If
        Set SortAreaB = Range(Cells(ADRange.Row, ADRange.Column) _
            , Cells(LDBEr, LDBEc))
        SortAreaB.Select
End Function

Function SortAreaC() As Range
    Dim LDB2, LDB2R As Range
        On Error Resume Next
        Set LDB2 = Application.InputBox("並び替えするデータ" & _
        "ブロック内で、" & vbCrLf & "いずれかのセルをクリック" & _
        "してください。" & vbCrLf & "セル位置に基づいて検索" & _
        "エリアをセットします。" & vbCrLf & " " & vbCrLf & "セル" & _
        "を置き直しする場合は「キャンセル」を選択してください。", _
        Title:="データブロックの指定", Type:=8)
        If Not LDB2 Is Nothing Then
            LDB2.Activate
        End If
        If Err.Number > 0 Then
            MsgBox "キャンセルされました。終了します。"
            ErEnd = True
        Exit Function
        End If
        On Error GoTo 0
        Set LDB2R = LDB2.CurrentRegion
        If Application.Intersect(ADRange, LDB2R) Is Nothing Then
           MsgBox "シートのデータ範囲外のセルを指定しました。" _
           & vbCrLf & "再指定してください。", vbExclamation, "再指定"
           ErEnd = True
           Exit Function
        End If
        Set SortAreaC = LDB2.CurrentRegion
        SortAreaC.Select
End Function

Function SortAreaD() As Range
        If ErEnd = True Then Exit Function
        Set SortAreaD = InpAreaV
End Function

Sub 並び替え範囲部分指定()
    Dim ANS As Long
        AreaVAlert = False
        Set InpAreaV = Nothing
        ソートナビゲーター.部分範囲指定表示.Value = ""
        On Error Resume Next
        Set InpAreaV = Application.InputBox("並び替え範囲を指定" & _
            "してください。", Title:="並び替え範囲指定", Type:=8)
        If Err.Number > 0 Then
            MsgBox "キャンセルされました。終了します。"
            ErEnd = True
            Exit Sub
        End If
        ソートナビゲーター.部分範囲指定表示.Value = _
            InpAreaV.Address(False, False)
        On Error GoTo 0
        With InpAreaV
            If Not (Cells(.Row, .Column).CurrentRegion.Columns.Count _
                = InpAreaV.Columns.Count And Cells(.Row, .Column) _
                .CurrentRegion.Column = InpAreaV.Column) Then
                AreaVAlert = True
                ANS = MsgBox("このまま並び替えを行うとデータを壊す" & _
                "可能性があります。" & vbCrLf & "続けますか？", _
                vbYesNo + vbQuestion, "確認")
            End If
            If ANS = 7 Then
                Exit Sub
            End If
        End With
        Set Bodu = InpAreaV.Borders(xlEdgeTop)
        Set Bodd = InpAreaV.Borders(xlEdgeBottom)
        Set Bodl = InpAreaV.Borders(xlEdgeLeft)
        Set Bodr = InpAreaV.Borders(xlEdgeRight)
        BoduL = Bodu.LineStyle
        BoduW = Bodu.Weight
        BoddL = Bodd.LineStyle
        BoddW = Bodd.Weight
        BodlL = Bodl.LineStyle
        BodlW = Bodl.Weight
        BodrL = Bodr.LineStyle
        BodrW = Bodr.Weight
        InpAreaV.BorderAround LineStyle:=xlContinuous, Weight:=xlThick
End Sub

Sub 並び替え範囲部分指定罫線消去()
        If ErEnd = True Then Exit Sub
        If InpAreaV Is Nothing Then
        MsgBox "今回は消去する罫線がないか、または、手作業での" & _
            "消去になります。"
        Exit Sub
        End If
        InpAreaV.Select
        With InpAreaV.Borders(xlEdgeTop)
            If BoduL = -4142 Then
                .LineStyle = xlLineStyleNone
            Else
                .LineStyle = BoduL
                .Weight = BoduW
            End If
        End With
        With InpAreaV.Borders(xlEdgeBottom)
            If BoddL = -4142 Then
                .LineStyle = xlLineStyleNone
            Else
                .LineStyle = BoddL
                .Weight = BoddW
            End If
        End With
        With InpAreaV.Borders(xlEdgeLeft)
            If BodlL = -4142 Then
                .LineStyle = xlLineStyleNone
            Else
                .LineStyle = BodlL
                .Weight = BodlW
            End If
        End With
        With InpAreaV.Borders(xlEdgeRight)
            If BodrL = -4142 Then
                .LineStyle = xlLineStyleNone
            Else
                .LineStyle = BodrL
                .Weight = BodrW
            End If
        End With
End Sub