並び替えマクロツール作成の全コード集

Option Explicit
'-----------------------------------------------------------------
Dim ADRange As Range
Dim DataNSN, DataSN As String
Dim ErEnd As Boolean
Dim SSRange As Range
Dim STRCr, STRCc As Long
Public KeyAddA, KeyAddB, KeyAddC As Variant
Public ClrNoA, ClrNoB, ClrNoC As Variant
Public RGBstyle As String
Dim Rno, GNo, BNo As Long
Public DataRange As String, Head As Long
Dim InpAreaV As Range
Public Stream1, Stream2, Stream3, Stream4, Stream5, Stream6 As Long
Dim Bodu, Bodd, Bodr, Bodl As Border
Dim BoduL, BoddL, BodrL, BodlL, BoduW, BoddW, BodrW, BodlW As Long
Public ClrNoACellc, ClrNoBCellc, ClrNoCCellc As Long
Public SortType As String
Public CusOdr1, CusOdr2, CusOdr3, CusOdr1V, CusOdr2V, CusOdr3V As Variant
Public DCutr, DCutc, DCutEr, DCutEc As Long
Public DCYr As String
Dim AreaVAlert As Boolean
'-----------------------------------------------------------------

'その他のコード
Function ws() As Worksheet
    Set ws = ActiveSheet
End Function
'-----------------------------------------------------------------

Sub グローバル変数初期化()
    Dim ANS As Long
        If Not ADRange Is Nothing Then
            ANS = MsgBox("「並び替えデータシート全体をチェック」も" & _
                "リセットしますか？", vbYesNo + vbQuestion, "確認")
                If ANS = 7 Then
                    MsgBox "承知しました。チェックのリセット" & _
                        "は行いません。"
                Else
                    Set ADRange = Nothing
                End If
        End If
        Set SSRange = Nothing
        Set InpAreaV = Nothing
        DataSN = ""
        ErEnd = False
        STRCr = 0
        STRCc = 0
        KeyAddA = ""
        KeyAddB = ""
        KeyAddC = ""
        ClrNoA = ""
        ClrNoB = ""
        ClrNoC = ""
        RGBstyle = ""
        Rno = 0
        GNo = 0
        BNo = 0
        DataRange = ""
        Head = 0
        Stream1 = ""
        Stream2 = ""
        Stream3 = ""
        Stream4 = ""
        Stream5 = ""
        Stream6 = 0
        ClrNoACellc = 0
        ClrNoBCellc = 0
        ClrNoCCellc = 0
        SortType = ""
        CusOdr1 = ""
        CusOdr2 = ""
        CusOdr3 = ""
        CusOdr1V = ""
        CusOdr2V = ""
        CusOdr3V = ""
        DCutr = 0
        DCutc = 0
        DCutEr = 0
        DCutEc = 0
        DCYr = 0
        AreaVAlert = False
End Sub
'-----------------------------------------------------------------

'データシート全体のボリュームを把握
Sub データシート把握()
    Dim ADSr, ADSc, ADEc As Range
    Dim Sr, Sc, Ec As String
    Dim SrN, ScN, EcN As Long
    Dim i As Long
    Dim ER() As Long
        ws.Select
        DataNSN = ws.Name
        On Error Resume Next
        Set ADSr = Application.InputBox("データの開始行を指定して" & _
            "ください。", Title:="データ開始行の指定", Type:=8)
        If ADSr Is Nothing Then
            MsgBox "キャンセルされました。終了します。"
            Exit Sub
        End If
        Set ADSc = Application.InputBox("データの開始列を指定して" & _
            "ください。", Title:="データ開始列の指定", Type:=8)
        If ADSc Is Nothing Then
            MsgBox "キャンセルされました。終了します。"
            Exit Sub
        End If
            Set ADEc = Application.InputBox("データの終了列を指定" & _
                "してください。", Title:="データ終了列の指定", Type:=8)
        If ADEc Is Nothing Then
            MsgBox "キャンセルされました。終了します。"
            Exit Sub
        End If
        Sr = ADSr.Address(, , xlR1C1)
        SrN = Val(Mid(Sr, 2))
        Sc = ADSc.Address(, , xlR1C1)
        ScN = Val(Mid(Sc, 2))
        Ec = ADEc.Address(, , xlR1C1)
        EcN = Val(Mid(Ec, 2))
    ReDim ER(ScN To EcN)
        For i = ScN To EcN
            ER(i) = Cells(Rows.Count, i).End(xlUp).Row
        Next i
        Set ADRange = Range(Cells(SrN, ScN), Cells(WorksheetFunction _
            .Max(ER), EcN))
End Sub
'-----------------------------------------------------------------

'並び替えデータエリア把握
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
            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
'-----------------------------------------------------------------

'その他のコード
Function RGB変換(ColorNo As Long)
        Rno = ColorNo Mod 256
        GNo = (ColorNo \ 256) Mod 256
        BNo = (ColorNo \ 256) \ 256
        RGBstyle = "RGB(" & Rno & "," & GNo & "," & BNo & ")"
End Function
'-----------------------------------------------------------------

Function CusOdr() As Variant
    Dim buf As String
    Dim TFile As String
    Dim result As Long
    Dim dialog As FileDialog
        Set dialog = Application.FileDialog(msoFileDialogOpen)
        MsgBox "ユーザー設定リストを選択します。", _
            vbInformation, "ユーザー設定"
        With dialog
            .ButtonName = "開く"
            .InitialFileName = ThisWorkbook.Path & _
                "\ユーザー設定リスト\"
            result = .Show
        End With
        If result = -1 Then
            TFile = dialog.SelectedItems.Item(1)
        Else
            MsgBox "ユーザー設定リスト選択がキャンセルされました。" _
                & vbCrLf & "ユーザー設定は利用できません。"
            Exit Function
        End If
        With CreateObject("ADODB.Stream")
            .Charset = "UTF-8"
            .Open
            .LoadFromFile TFile
            buf = .ReadText
            .Close
            CusOdr = Replace(buf, vbLf, ",")
        End With
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
'-----------------------------------------------------------------

Sub 並び替え作業()
    Dim ANS As Long
        DataSN = ws.Name
        If DataNSN <> DataSN Then
        MsgBox "シートが変更されましたので、並び替えデータシート" _
            & "全体のチェックが必要です。" & vbCrLf & _
            "「並び替えデータシート全体チェック」をまず実行して" _
            & "ください。", vbInformation, "実行するには・・"
        Exit Sub
        End If
        Set SSRange = Nothing
        If Not DataRange = "Type1" Then
            If ErEnd = True Then
                ANS = MsgBox("「条件設定の不備」を修正しましたか？" _
                            , vbYesNo + vbQuestion, "確認")
                If ANS = 7 Then
                    MsgBox "不備を修正してください。終了します。"
                    Exit Sub
                Else
                    ErEnd = False
                End If
            End If
        End If

        If DataRange = "Type1" Then
            Set SSRange = SortAreaA
        ElseIf DataRange = "Type2" Then
            Set SSRange = SortAreaB
        ElseIf DataRange = "Type3" Then
            Set SSRange = SortAreaC
        ElseIf DataRange = "Type4" Then
            Set SSRange = SortAreaD
        End If
        
        If ErEnd = True Then
            MsgBox "一旦終了します。"
            Exit Sub
        End If
        
        If CusOdr1 = "ON" Then
            MsgBox "並び替え列1のユーザー設定リストの設定"
            CusOdr1V = CusOdr
        End If
        If CusOdr2 = "ON" Then
            MsgBox "並び替え列2のユーザー設定リストの設定"
            CusOdr2V = CusOdr
        End If
        If CusOdr3 = "ON" Then
            MsgBox "並び替え列3のユーザー設定リストの設定"
            CusOdr3V = CusOdr
        End If
        
        If SortType = "StypeA" Then
            Call Module1.Sort実行
        ElseIf SortType = "StypeB" Then
            Call Module1.Sort背景色
        ElseIf SortType = "StypeC" Then
            Call Module1.Sort列から背景色
        ElseIf SortType = "StypeD" Then
            Call Module1.Sort背景色から列
        Else
            Call Module1.Sort実行
        End If
        
        'データ切り出し用
        With SSRange
        If SSRange Is Nothing Then Exit Sub
            DCutr = .Row
            DCutc = .Column
            DCutEr = .Rows.Count + DCutr - 1
            DCutEc = .Columns.Count + DCutc - 1
        End With
        
        CusOdr1V = ""
        CusOdr2V = ""
        CusOdr3V = ""

        ソートナビゲーター.部分範囲指定表示.Value = ""
End Sub
'-----------------------------------------------------------------

Sub Sort実行()
        On Error Resume Next
            ws.Sort.SortFields.Clear
            If CusOdr1 = "ON" Then
                ws.Sort.SortFields.Add Key:=ws.Range(KeyAddA), _
                Order:=Stream1, CustomOrder:="""" & CusOdr1V & """", _
                        DataOption:=xlSortNormal
            Else
                ws.Sort.SortFields.Add Key:=ws.Range(KeyAddA), _
                Order:=Stream1
            End If
            If CusOdr2 = "ON" Then
                ws.Sort.SortFields.Add Key:=ws.Range(KeyAddB), _
                Order:=Stream2, CustomOrder:="""" & CusOdr2V & """", _
                        DataOption:=xlSortNormal
            Else
                ws.Sort.SortFields.Add Key:=ws.Range(KeyAddB), _
                Order:=Stream2
            End If
            If CusOdr3 = "ON" Then
                ws.Sort.SortFields.Add Key:=ws.Range(KeyAddC), _
                Order:=Stream3, CustomOrder:="""" & CusOdr3V & """", _
                        DataOption:=xlSortNormal
            Else
                ws.Sort.SortFields.Add Key:=ws.Range(KeyAddC), _
                Order:=Stream3
            End If
        With ws.Sort
            .SetRange SSRange
            .Header = Head
            .Apply
        End With
        Cells(SSRange.Rows.Count, SSRange.Columns.Count). _
            Offset(1, 1).Select
        MsgBox "並び替えが完了しました。"
        With ソートナビゲーター
            .並び替え列1セル.Value = ""
            .並び替え列2セル.Value = ""
            .並び替え列3セル.Value = ""
        End With
        On Error GoTo 0
End Sub
'-----------------------------------------------------------------

Sub Sort背景色()
        On Error Resume Next
        ws.Sort.SortFields.Clear
        ws.Sort.SortFields.Add(Cells(1, ClrNoACellc), _
                xlSortOnCellColor, Stream4, , xlSortNormal). _
                    SortOnValue.Color = ClrNoA
        ws.Sort.SortFields.Add(Cells(1, ClrNoBCellc), _
                xlSortOnCellColor, Stream5, , xlSortNormal). _
                    SortOnValue.Color = ClrNoB
        ws.Sort.SortFields.Add(Cells(1, ClrNoCCellc), _
                xlSortOnCellColor, Stream6, , xlSortNormal). _
                    SortOnValue.Color = ClrNoC
        With ws.Sort
            .SetRange SSRange
            .Header = Head
            .Apply
        End With
        On Error GoTo 0
        Cells(SSRange.Rows.Count, SSRange.Columns.Count). _
            Offset(1, 1).Select
        MsgBox "並び替えが完了しました。"
        With ソートナビゲーター
            .背景色選択1.Value = ""
            .背景色選択2.Value = ""
            .背景色選択3.Value = ""
        End With
End Sub
'-----------------------------------------------------------------

Sub Sort列から背景色()
        On Error Resume Next
        ws.Sort.SortFields.Clear
            If CusOdr1 = "ON" Then
                ws.Sort.SortFields.Add Key:=ws.Range(KeyAddA), _
                Order:=Stream1, CustomOrder:="""" & CusOdr1V & """", _
                        DataOption:=xlSortNormal
            Else
                ws.Sort.SortFields.Add Key:=ws.Range(KeyAddA), _
                    Order:=Stream1
            End If
            If CusOdr2 = "ON" Then
                ws.Sort.SortFields.Add Key:=ws.Range(KeyAddB), _
                Order:=Stream2, CustomOrder:="""" & CusOdr2V & """", _
                    DataOption:=xlSortNormal
            Else
                ws.Sort.SortFields.Add Key:=ws.Range(KeyAddB), _
                    Order:=Stream2
            End If
            If CusOdr3 = "ON" Then
                ws.Sort.SortFields.Add Key:=ws.Range(KeyAddC), _
                Order:=Stream3, CustomOrder:="""" & CusOdr3V & """", _
                    DataOption:=xlSortNormal
            Else
                ws.Sort.SortFields.Add Key:=ws.Range(KeyAddC), _
                    Order:=Stream3
            End If
            ws.Sort.SortFields.Add(Cells(1, ClrNoACellc), _
                    xlSortOnCellColor, Stream4, , xlSortNormal). _
                        SortOnValue.Color = ClrNoA
            ws.Sort.SortFields.Add(Cells(1, ClrNoBCellc), _
                    xlSortOnCellColor, Stream5, , xlSortNormal). _
                        SortOnValue.Color = ClrNoB
            ws.Sort.SortFields.Add(Cells(1, ClrNoCCellc), _
                    xlSortOnCellColor, Stream6, , xlSortNormal). _
                        SortOnValue.Color = ClrNoC
        With ws.Sort
            .SetRange SSRange
            .Header = Head
            .Apply
        End With
        On Error GoTo 0
        Cells(SSRange.Rows.Count, SSRange.Columns.Count). _
            Offset(1, 1).Select
        MsgBox "並び替えが完了しました。"
        With ソートナビゲーター
            .並び替え列1セル.Value = ""
            .並び替え列2セル.Value = ""
            .並び替え列3セル.Value = ""
            .背景色選択1.Value = ""
            .背景色選択2.Value = ""
            .背景色選択3.Value = ""
        End With
End Sub
'-----------------------------------------------------------------

Sub Sort背景色から列()
        On Error Resume Next
            ws.Sort.SortFields.Clear
            ws.Sort.SortFields.Add(Cells(1, ClrNoACellc), _
                    xlSortOnCellColor, Stream4, , xlSortNormal). _
                        SortOnValue.Color = ClrNoA
            ws.Sort.SortFields.Add(Cells(1, ClrNoBCellc), _
                    xlSortOnCellColor, Stream5, , xlSortNormal). _
                        SortOnValue.Color = ClrNoB
            ws.Sort.SortFields.Add(Cells(1, ClrNoCCellc), _
                    xlSortOnCellColor, Stream6, , xlSortNormal). _
                        SortOnValue.Color = ClrNoC
            If CusOdr1 = "ON" Then
                ws.Sort.SortFields.Add Key:=ws.Range(KeyAddA), _
                Order:=Stream1, CustomOrder:="""" & CusOdr1V & """", _
                    DataOption:=xlSortNormal
            Else
                ws.Sort.SortFields.Add Key:=ws.Range(KeyAddA), _
                    Order:=Stream1
            End If
            If CusOdr2 = "ON" Then
                ws.Sort.SortFields.Add Key:=ws.Range(KeyAddB), _
                Order:=Stream2, CustomOrder:="""" & CusOdr2V & """", _
                    DataOption:=xlSortNormal
            Else
                ws.Sort.SortFields.Add Key:=ws.Range(KeyAddB), _
                    Order:=Stream2
            End If
            If CusOdr3 = "ON" Then
                ws.Sort.SortFields.Add Key:=ws.Range(KeyAddC), _
                Order:=Stream3, CustomOrder:="""" & CusOdr3V & """", _
                    DataOption:=xlSortNormal
            Else
                ws.Sort.SortFields.Add Key:=ws.Range(KeyAddC), _
                    Order:=Stream3
            End If
        With ws.Sort
            .SetRange SSRange
            .Header = Head
            .Apply
        End With
        On Error GoTo 0
        Cells(SSRange.Rows.Count, SSRange.Columns.Count). _
            Offset(1, 1).Select
        MsgBox "並び替えが完了しました。"
        With ソートナビゲーター
            .並び替え列1セル.Value = ""
            .並び替え列2セル.Value = ""
            .並び替え列3セル.Value = ""
            .背景色選択1.Value = ""
            .背景色選択2.Value = ""
            .背景色選択3.Value = ""
        End With
End Sub
'-----------------------------------------------------------------

Sub リスタート実行()
    ErEnd = False
    Dim ANS, Ans1 As Long
    
        If AreaVAlert = True Then
            MsgBox "並び替えの部分指定でデータ幅不一致の場合は、" _
                & "この機能は使用できません。"
            Exit Sub
        End If
        DataSN = ws.Name
        If DataNSN <> DataSN Then
            MsgBox "シートが変更されましたので、並び替えデータ" _
                & "シート全体のチェックが必要です。" & vbCrLf & _
                "「並び替えデータシート全体チェック」をまず実行" _
                & "してください。", vbInformation, "実行するには・・"
        Exit Sub
        End If
    If ADRange Is Nothing Then
        MsgBox "並び替えデータシート全体のチェックが必要です。" _
            & vbCrLf & "「並び替えデータシート全体チェック」を" _
            & "まず実行してください。" _
            , vbInformation, "実行するには・・"
        Exit Sub
    End If
        If ErEnd = True Then
            MsgBox "この操作は、条件設定の不備により実行されません。"
            Exit Sub
        End If
        On Error Resume Next
        With ws
            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=Range("A1"), Order:=xlAscending
            .Sort.SetRange ADRange.CurrentRegion
            With ソートナビゲーター
                If .先頭行は見出し行 = True Then
                    ws.Sort.Header = xlYes
                ElseIf .先頭行はデータ行 = True Then
                    ws.Sort.Header = xlNo
                Else
                    MsgBox "先頭行のタイプを選んでください。" _
                        , vbExclamation, "再試行"
                    Exit Sub
                End If
            End With
            Ans1 = MsgBox("A列基準で昇順並び替えを実行します。よろしい" _
                & "ですか？", vbOKCancel + vbExclamation, "実行確認")
            If Ans1 = 2 Then
                MsgBox "承知しました中止します。"
                Exit Sub
            Else
                .Sort.Apply
            End If
        End With
        On Error GoTo 0
End Sub
'-----------------------------------------------------------------

Sub 並び替えデータ切り出し()
    Dim DCArea, DCAreaS As Range
    Dim KArow As Long
        On Error Resume Next
        Set DCArea = Range(Cells(DCutr, DCutc), Cells(DCutEr, DCutEc))
        If DCArea Is Nothing Then
            MsgBox "切り出すものがありません。"
            Exit Sub
        End If
        If Val(DCYr) <= 0 Then
            MsgBox "切り出し行数をもう一度チェックしてください。", _
                vbOKOnly + vbExclamation
            ソートナビゲーター.切り出し希望行数.Value = ""
            Exit Sub
        End If
        If DCutEr - (Val(DCYr) + DCutr - 1) >= 0 Then
            Set DCAreaS = Range(Cells(DCutr, DCutc), Cells(Val(DCYr) _
                + DCutr - 1, DCutEc))
        Else
        Cells(DCutEr, DCutEc).EntireRow.Select
            MsgBox "切り出し行数をもう一度チェックしてください。", _
                vbOKOnly + vbExclamation
            ソートナビゲーター.切り出し希望行数.Value = ""
            Exit Sub
        End If
    Dim Flag As Boolean
    Dim wsheet As Worksheet
        For Each wsheet In ThisWorkbook.Worksheets
            If wsheet.Name = "切り出し" Then
                Flag = True
                Exit For
            Else
                Flag = False
            End If
        Next
        If Flag = False Then
            ThisWorkbook.Worksheets.Add(after:=Worksheets(1)) _
                .Name = "切り出し"
        End If
        Worksheets("切り出し").Select
        KArow = Cells(Rows.Count, 2).End(xlUp).Row + 2
        DCAreaS.Copy Worksheets("切り出し").Cells(KArow, 2)
        Worksheets(DataSN).Select
        On Error GoTo 0
End Sub
'-----------------------------------------------------------------

Option Explicit

'-----------------------------------------------------------------
Private Sub データシートチェックボタン_Click()
    Call Module1.データシート把握
End Sub

'-----------------------------------------------------------------

Private Sub UFリセット_Click()
    Unload ソートナビゲーター
    Call Module1.グローバル変数初期化
    ソートナビゲーター.Show vbModeless
End Sub

'-----------------------------------------------------------------

Private Sub 部分範囲指定_Click()
    データ範囲4 = True
    Module1.並び替え範囲部分指定
End Sub

'-----------------------------------------------------------------

Private Sub 範囲指定罫線消去_Click()
    Module1.並び替え範囲部分指定罫線消去
End Sub

'-----------------------------------------------------------------

Private Sub 並び替え列1確定_Click()
    並び替え列1セル.Value = ActiveCell.Address(False, False)
    If 並び替え列1セル.Value <> "" Then
        KeyAddA = 並び替え列1セル.Value
    End If
    If 昇順1 = True Then
        Stream1 = xlAscending
    ElseIf 降順1 = True Then
        Stream1 = xlDescending
    Else
        Stream1 = xlAscending
        昇順1 = True
    End If
End Sub

'-----------------------------------------------------------------

Private Sub 列1消去_Click()
    並び替え列1セル.Value = ""
End Sub

'-----------------------------------------------------------------

Private Sub 並び替え列2確定_Click()
    並び替え列2セル.Value = ActiveCell.Address(False, False)
    If 並び替え列2セル.Value <> "" Then
    KeyAddB = 並び替え列2セル.Value
    End If
    If 昇順2 = True Then
        Stream2 = xlAscending
    ElseIf 降順2 = True Then
        Stream2 = xlDescending
    Else
        Stream2 = xlAscending
        昇順2 = True
    End If
End Sub

'-----------------------------------------------------------------

Private Sub 列2消去_Click()
    並び替え列2セル.Value = ""
End Sub

'-----------------------------------------------------------------

Private Sub 並び替え列3確定_Click()
    並び替え列3セル.Value = ActiveCell.Address(False, False)
    If 並び替え列3セル.Value <> "" Then
    KeyAddC = 並び替え列3セル.Value
    End If
    If 昇順3 = True Then
        Stream3 = xlAscending
    ElseIf 降順3 = True Then
        Stream3 = xlDescending
    Else
        Stream3 = xlAscending
        昇順3 = True
    End If
End Sub

'-----------------------------------------------------------------

Private Sub 列3消去_Click()
    並び替え列3セル.Value = ""
End Sub

'-----------------------------------------------------------------

Private Sub 背景色選択1確定_Click()
    背景色選択1.Value = ActiveCell.Interior.Color
    ClrNoA = 背景色選択1.Value
    Call Module1.RGB変換(Val(ClrNoA))
    背景色選択1.Value = RGBstyle
    ClrNoACellc = ActiveCell.Column
    If 昇順4 = True Then
        Stream4 = xlAscending
    ElseIf 降順4 = True Then
        Stream4 = xlDescending
    Else
        Stream4 = xlAscending
        昇順4 = True
    End If
End Sub

'-----------------------------------------------------------------

Private Sub 色1消去_Click()
    背景色選択1.Value = ""
End Sub

'-----------------------------------------------------------------

Private Sub 背景色選択2確定_Click()
    背景色選択2.Value = ActiveCell.Interior.Color
    ClrNoB = 背景色選択2.Value
    Call Module1.RGB変換(Val(ClrNoB))
    背景色選択2.Value = RGBstyle
    ClrNoBCellc = ActiveCell.Column
    If 昇順5 = True Then
        Stream5 = xlAscending
    ElseIf 降順5 = True Then
        Stream5 = xlDescending
    Else
        Stream5 = xlAscending
        昇順5 = True
    End If
End Sub

'-----------------------------------------------------------------

Private Sub 色2消去_Click()
    背景色選択2.Value = ""
End Sub

'-----------------------------------------------------------------

Private Sub 背景色選択3確定_Click()
    背景色選択3.Value = ActiveCell.Interior.Color
    ClrNoC = 背景色選択3.Value
    Call Module1.RGB変換(Val(ClrNoC))
    背景色選択3.Value = RGBstyle
    ClrNoCCellc = ActiveCell.Column
    If 昇順6 = True Then
        Stream6 = xlAscending
    ElseIf 降順6 = True Then
        Stream6 = xlDescending
    Else
        Stream6 = xlAscending
        昇順6 = True
    End If
End Sub

'-----------------------------------------------------------------

Private Sub 色3消去_Click()
    背景色選択3.Value = ""
End Sub

'-----------------------------------------------------------------

Private Sub ユーザー設定リストなし_Click()
    If ユーザー設定リスト使う = True Then
        ユーザー設定リストフレーム.Visible = True
    ElseIf ユーザー設定リスト使う = False Then
        ユーザー設定リストフレーム.Visible = False
    End If
End Sub

'-----------------------------------------------------------------

Private Sub ユーザー設定リスト使う_Click()
    If ユーザー設定リスト使う = True Then
        ユーザー設定リストフレーム.Visible = True
    ElseIf ユーザー設定リスト使う = False Then
        ユーザー設定リストフレーム.Visible = False
    End If
End Sub

'-----------------------------------------------------------------

Private Sub 列並び替え_Click()
    If 複合並び替え = True Then
        複合キーフレーム.Visible = True
    ElseIf 複合並び替え = False Then
        複合キーフレーム.Visible = False
    End If
End Sub

'-----------------------------------------------------------------

Private Sub 色並び替え_Click()
    If 複合並び替え = True Then
        複合キーフレーム.Visible = True
    ElseIf 複合並び替え = False Then
        複合キーフレーム.Visible = False
    End If
End Sub

'-----------------------------------------------------------------

Private Sub 複合並び替え_Click()
    If 複合並び替え = True Then
        複合キーフレーム.Visible = True
    ElseIf 複合並び替え = False Then
        複合キーフレーム.Visible = False
    End If
End Sub

'-----------------------------------------------------------------

Private Sub 並び替えGO_Click()
Dim ANS, Ans1, Ans2, Ans3 As Long
'-------- 1 ↓↓↓ここから-----------
    ANS = MsgBox("並び替えデータシート全体のチェックは終わって" & _
        "いますか？" & vbCrLf & "続けますか？", _
        vbYesNo + vbQuestion, "確認")
    If ANS = 7 Then
        MsgBox "承知しました。チェックを行ってください。"
        Exit Sub
    End If
        
    If データ範囲1 = True Then
        DataRange = "Type1"
    ElseIf データ範囲2 = True Then
        DataRange = "Type2"
    ElseIf データ範囲3 = True Then
        DataRange = "Type3"
    ElseIf データ範囲4 = True Then
        DataRange = "Type4"
        If 部分範囲指定表示.Value = "" Then
            MsgBox "範囲指定を行なわないと並び替えが出来ません。" _
                & vbCrLf & "一旦終了します。", vbCritical, "範囲指定"
            Exit Sub
        End If
    Else
        MsgBox "データ範囲が不明です。データ範囲を指定しないと" & _
            "並び替えが出来ません。" _
            & vbCrLf & "一旦終了します。", vbCritical, "データ範囲"
        Exit Sub
    End If
'-------- 1 ↑↑↑ここまで-----------
'-------- 2 ↓↓↓ここから-----------
    If 先頭行あり = True Then
        Head = xlYes
    ElseIf 先頭行なし = True Then
        Head = xlNo
    Else
        Ans1 = MsgBox("先頭行の指定がない場合は「先頭行は見出し」" & _
        "にセットされます。" & vbCrLf & "続けますか？" _
                , vbYesNo + vbQuestion, "確認")
        If Ans1 = 6 Then
            ソートナビゲーター.先頭行あり = True
            Head = xlYes
        ElseIf Ans1 = 7 Then
            MsgBox "設定してください。"
            Exit Sub
        End If
    End If
'-------- 2 ↑↑↑ここまで-----------
'-------- 3 ↓↓↓ここから-----------
    If ユーザー設定リストなし = False And _
                                    ユーザー設定リスト使う = False Then
        Ans2 = MsgBox("ユーザー設定リストの指定がない場合は" & _
            "「設定なし」にセットされます。" & vbCrLf & "続けますか？" _
                , vbYesNo + vbQuestion, "確認")
        If Ans2 = 7 Then
            MsgBox "設定してください。"
            Exit Sub
        ElseIf Ans2 = 6 Then
            ユーザー設定リストなし = True
        End If
    End If
    If ユーザー設定リスト列1ON = True Then
        CusOdr1 = "ON"
    Else
        CusOdr1 = ""
    End If
    If ユーザー設定リスト列2ON = True Then
        CusOdr2 = "ON"
    Else
        CusOdr2 = ""
    End If
    If ユーザー設定リスト列3ON = True Then
        CusOdr3 = "ON"
    Else
        CusOdr3 = ""
    End If

    If 列並び替え = True Then
        SortType = "StypeA"
    ElseIf 色並び替え = True Then
        SortType = "StypeB"
    ElseIf 複合並び替え = True Then
        If キー優先列 = True Then
            SortType = "StypeC"
        ElseIf キー優先色 = True Then
            SortType = "StypeD"
        Else
            SortType = "StypeC"
        End If
    Else
        Ans3 = MsgBox("並び替え方法の指定がない場合は「列キー単独」" & _
            "にセットされます。" & vbCrLf & "よろしいですか？" _
                    , vbYesNo + vbQuestion, "確認")
        If Ans3 = 6 Then
            ソートナビゲーター.列並び替え = True
            SortType = "StypeA"
        ElseIf Ans3 = 7 Then
            MsgBox "設定してください。。"
            Exit Sub
        End If
    End If
    Call Module1.並び替え作業
    ユーザー設定リスト列1ON.Value = False
    ユーザー設定リスト列2ON.Value = False
    ユーザー設定リスト列3ON.Value = False
    キー優先列.Value = False
    キー優先色.Value = False
'-------- 3 ↑↑↑ここまで-----------
End Sub

'-----------------------------------------------------------------

Private Sub 切り出し全行数_Click()
    With 切り出し全行数
    If DCutEr = 0 Then
        MsgBox "切り出すものがありません。"
        Exit Sub
    End If
        .TextAlign = fmTextAlignCenter
        .Caption = DCutEr - DCutr + 1 & "行"
        .Font.Bold = True
        .Font.Size = 14
    End With
End Sub

'-----------------------------------------------------------------

Private Sub データ切り出し実行_Click()
    DCYr = 切り出し希望行数.Value
    With 切り出し全行数
        .TextAlign = fmTextAlignLeft
        .Caption = "ここをクリックすると切り出し可能な最大行数を" & _
                    "表示します。"
        .Font.Bold = False
        .Font.Size = 8
    End With
    Call Module1.並び替えデータ切り出し
End Sub

'-----------------------------------------------------------------

Private Sub リスタート_Click()
Call Module1.リスタート実行
End Sub
'-----------------------------------------------------------------

Option Explicit

'-----------------------------------------------------------------
Private Sub Worksheet_Activate()
If ソートナビゲーター.Visible = False Then ソートナビゲーター.Show vbModeless
End Sub

Option Explicit

'-----------------------------------------------------------------
Private Sub Workbook_Open()
If ソートナビゲーター.Visible = False Then ソートナビゲーター.Show vbModeless
End Sub