SortArray2D_WS

'SortArray2D_WS   ・・・元場所：VBAProject.Mod99_アドインから
'IsArray2D        ・・・元場所：VBAProject.Mod99_アドインから
'IsArray2DStart1  ・・・元場所：VBAProject.Mod99_アドインから
'Judge__CanUseSort・・・元場所：VBAProject.Mod99_アドインから
'SortArray2D      ・・・元場所：VBAProject.Mod99_アドインから
'ExtractColArray2D・・・元場所：VBAProject.Mod99_アドインから
'SortArray2Dby1D  ・・・元場所：VBAProject.Mod99_アドインから
'ConvStrToISO     ・・・元場所：VBAProject.Mod99_アドインから
'DimArray1DNumbers・・・元場所：VBAProject.Mod99_アドインから
'SortArrayQuick   ・・・元場所：VBAProject.Mod99_アドインから

Public Function SortArray2D_WS(ByRef Array2D As Variant, _
                          Optional ByRef Col As Long = 1, _
                        Optional ByRef Order As XlSortOrder = xlAscending) _
                                             As Variant
'二次元配列の指定列を基準に並び替える
'WorksheetFunction.Sort関数を利用する
'20240126
'20240209 WorksheetFunction.Sortが使用できるかできないかの判定および代替処理追加
'20240214 1行分だった場合の処理追加
'20240216 要素がオブジェクトの場合の処理追加

'引数
'Array2D   ・・・二次元配列
'[SortCol] ・・・並び替えの基準列'省略なら1
'[Order]   ・・・xlAscending→昇順(デフォルト)
'                xlDescending→降順
    
    '※※※※※※※※※※※※※※※※※※※※※※※※※※
    '引数チェック
    If IsArray2D(Array2D) = False Then Exit Function
    If IsArray2DStart1(Array2D) = False Then Exit Function
    
    '※※※※※※※※※※※※※※※※※※※※※※※※※※
    '処理
    '対象の列から番号列を追加して作成
    Dim N As Long: N = UBound(Array2D, 1) '縦要素数
    If N = 1 Then '1行分だったら何も処理しない
        SortArray2D_WS = Array2D
        Exit Function
    End If
    
    Dim I              As Long
    Dim TargetColArray As Variant
    ReDim TargetColArray(1 To N, 1 To 2)
    For I = 1 To N
        If IsDate(Array2D(I, Col)) = True Then
            '日付型は正しく処理されないので数値型に一度変換する
            TargetColArray(I, 1) = CDbl(CDate(Array2D(I, Col)))
        Else
            TargetColArray(I, 1) = Array2D(I, Col)
        End If
        TargetColArray(I, 2) = I
    Next
    
    'TargetColArrayを並び替え
    If Order = xlAscending Then
        '昇順の場合
        If Judge__CanUseSort = True Then
            TargetColArray = WorksheetFunction.Sort(TargetColArray, 1, 1)
        Else
            TargetColArray = SortArray2D(TargetColArray, 1, xlAscending)
        End If
    Else
        '降順の場合
        If Judge__CanUseSort = True Then
            TargetColArray = WorksheetFunction.Sort(TargetColArray, 1, -1)
        Else
            TargetColArray = SortArray2D(TargetColArray, 1, xlDescending)
        End If
    End If
    
    '出力配列作成
    Dim M      As Long: M = UBound(Array2D, 2) '横要素数
    Dim J      As Long
    Dim Output As Variant: ReDim Output(1 To N, 1 To M)
    Dim Row    As Long
    For I = 1 To N
        Row = TargetColArray(I, 2) '並び替え後の行番号を取得
        For J = 1 To M
            If IsObject(Array2D(Row, J)) = False Then
                Output(I, J) = Array2D(Row, J)
            Else
                Set Output(I, J) = Array2D(Row, J)
            End If
        Next
    Next
        
    '出力
    SortArray2D_WS = Output
        
End Function

Private Function IsArray2D(ByRef Array2D As Variant, _
               Optional ByRef ArrayName As String = "Array2D") _
                                        As Boolean
'入力配列が二次元配列かどうかチェックする
'20210804
'20220309 変数名変更
'20241230 Functionプロシージャにして判定結果を返す
'https://www.softex-celware.com/post/isarray1d

'引数
'Array2D    ・・・チェックする配列
'[ArrayName]・・・エラーメッセージで表示する時の名前

    On Error Resume Next
    Dim Dummy2 As Long: Dummy2 = UBound(Array2D, 2)
    Dim Dummy3 As Long: Dummy3 = UBound(Array2D, 3)
    On Error GoTo 0
    If Dummy2 = 0 Or Dummy3 <> 0 Then
        MsgBox ArrayName & "は二次元配列を入力してください", vbExclamation
        Stop 'エラーを確認するために一度停止する
        Exit Function 'Falseが返ってくる
    End If
    
    '出力
    IsArray2D = True
    
End Function

Private Function IsArray2DStart1(ByRef Array2D As Variant, _
                     Optional ByRef ArrayName As String = "Array2D") _
                                              As Boolean
'入力二次元配列の開始番号が1かどうかチェックする
'20210804
'20220309 変数名変更
'20241230 Functionプロシージャにして判定結果を返す
'https://www.softex-celware.com/post/isarray1d

'引数
'Array2D    ・・・チェックする二次元配列
'[ArrayName]・・・エラーメッセージで表示する時の名前

    If LBound(Array2D, 1) <> 1 Or LBound(Array2D, 2) <> 1 Then
        MsgBox ArrayName & "の開始要素番号は1にしてください", vbExclamation
        Stop 'エラーを確認するために一度停止する
        Exit Function 'Falseが返ってくる
    End If
    
    '出力
    IsArray2DStart1 = True

End Function

Private Function Judge__CanUseSort() As Boolean
'WorksheetFunction.Sort関数が使用できるかどうかを判定する
'20240209
    Dim Array2D As Variant: ReDim Array2D(1 To 2, 1 To 2)
    On Error GoTo ErrorEscape
    Array2D = WorksheetFunction.Sort(Array2D, 1, 1)
    Judge__CanUseSort = True
    Exit Function

ErrorEscape:
    Judge__CanUseSort = False
    Exit Function

End Function

Private Function SortArray2D(ByRef Array2D As Variant, _
                   Optional ByRef SortCol As Long = 1, _
                     Optional ByRef Order As XlSortOrder = xlAscending) _
                                          As Variant

'指定の二次元配列を、指定列を基準に並び替える
'配列は文字列を含んでいてもよい
'20210726
'https://www.softex-celware.com/post/sortarray2d

'引数
'Array2D   ・・・並び替え対象の二次元配列
'[SortCol] ・・・並び替えの基準で指定する列番号'省略なら1
'[Order]   ・・・xlAscending→昇順, xlDescending→降順/省略なら昇順
    
    '引数チェック
    If IsArray2D(Array2D) = False Then Exit Function
    If IsArray2DStart1(Array2D) = False Then Exit Function
    
    '指定列を一次元配列で抽出
    Dim SortColArray1D As Variant: SortColArray1D = ExtractColArray2D(Array2D, SortCol)
    
    '並び替え
    Dim Output As Variant: Output = SortArray2Dby1D(Array2D, SortColArray1D, Order)
    SortArray2D = Output
    
End Function

Private Function ExtractColArray2D(ByRef Array2D As Variant, _
                                      ByRef Col As Long) _
                                                As Variant
'二次元配列の指定列を一次元配列で抽出する
'20210917
'20211016修正 配列の中身がオブジェクト変数でも対応
'https://www.softex-celware.com/post/extractcolarray2d

'引数
'Array2D・・・二次元配列
'Col    ・・・抽出する対象の列番号

'返り値
'抽出された列の値が入った一次元配列

    '引数チェック
    If IsArray2D(Array2D) = False Then Exit Function       '二次元配列かチェック
    If IsArray2DStart1(Array2D) = False Then Exit Function '開始要素番号が1かチェック
    
    Dim I As Long
    Dim N As Long: N = UBound(Array2D, 1) '行数
    Dim M As Long: M = UBound(Array2D, 2) '列数
 
    If Col < 1 Then
        MsgBox "抽出する列番号は1以上の値を入れてください", vbExclamation
        Stop
        Exit Function
    ElseIf Col > M Then
        MsgBox "抽出する列番号は元の二次元配列の行数" & M & "以下の値を入れてください", vbExclamation
        Stop
        Exit Function
    End If
    
    '処理
    Dim Output As Variant: ReDim Output(1 To N)
    For I = 1 To N
        If IsObject(Array2D(I, Col)) Then '要素がオブジェクトの場合
            Set Output(I) = Array2D(I, Col)
        Else
            Output(I) = Array2D(I, Col)
        End If
    Next I
    
    '出力
    ExtractColArray2D = Output
    
End Function

Private Function SortArray2Dby1D(ByRef Array2D As Variant, _
                         ByVal SortColArray1D As Variant, _
                         Optional ByRef Order As XlSortOrder = xlAscending)
'指定の二次元配列を、指定一次元配列を基準に並び替える
'配列は文字列を含んでいてもよい
'20210726
'20210917修正
'20211016修正 配列のの中身がオブジェクト変数でも対応
                                   
'引数
'Array2D・・・並び替え対象の二次元配列
'SortColArray1D・・・並び替えの基準となる配列
'[Order]・・・xlAscending→昇順, xlDescending→降順/省略なら昇順

    '入力値のチェック
    
    If IsArray2D(Array2D) = False Then Exit Function
    If IsArray2DStart1(Array2D) = False Then Exit Function
    
    Dim MaxRow As Long: MaxRow = UBound(Array2D, 1)
    Dim MaxCol As Long: MaxCol = UBound(Array2D, 2)
    If MaxRow <> UBound(SortColArray1D, 1) Then
        MsgBox "並び替え対象の配列と、基準配列の開始、終了要素番号を一致させてください", vbInformation
        Stop
        Exit Function
    End If
    
    '基準配列に文字列が含まれている場合はISOコードに変換
    Dim JudgeIncludeStr As Boolean: JudgeIncludeStr = False
    Dim I               As Long
    Dim J               As Long
    Dim Tmp             As Variant
    Dim TmpStr          As String
    For I = 1 To MaxRow
        Tmp = SortColArray1D(I)
        If VarType(Tmp) = vbString Then
            JudgeIncludeStr = True
            Exit For
        End If
    Next I
    
    If JudgeIncludeStr = True Then
        For I = 1 To MaxRow
            TmpStr = SortColArray1D(I)
            SortColArray1D(I) = ConvStrToISO(TmpStr)
        Next I
    End If
    
    '基準配列を正規化して、(1～要素数)の間の数値にする
    Dim Count  As Long:   Count = MaxRow
    Dim MinVal As Double: MinVal = WorksheetFunction.Min(SortColArray1D)
    Dim MaxVal As Double: MaxVal = WorksheetFunction.Max(SortColArray1D)
    Dim Output As Variant
    If MinVal = MaxVal Then '20211016修正'最大と最小が一致するならそのまま返す
        Output = Array2D
        GoTo EndEscape
    End If
    
    For I = 1 To MaxRow
        SortColArray1D(I) = (SortColArray1D(I) - MinVal) / (MaxVal - MinVal) '(0～1)の間で正規化
        SortColArray1D(I) = (Count - 1) * SortColArray1D(I) + 1 '(1～要素数)の間
    Next I
    
    '並び替え(1,2,3の配列を作ってクイックソートで並び替えて、対象の配列を並び替え後の1,2,3で入れ替える)
    Dim Array123 As Variant: Array123 = DimArray1DNumbers(1, MaxRow)
    Dim TmpNum   As Long
        
    Call SortArrayQuick(SortColArray1D, Array123)
    
    ReDim Output(1 To MaxRow, 1 To MaxCol)
    For I = 1 To MaxRow
        TmpNum = Array123(I)
        For J = 1 To MaxCol
            If Order = xlAscending Then
                If IsObject(Array2D(TmpNum, J)) = True Then
                    Set Output(I, J) = Array2D(TmpNum, J)
                Else
                    Output(I, J) = Array2D(TmpNum, J)
                End If
            Else
                If IsObject(Array2D(TmpNum, J)) = True Then
                    Set Output(MaxRow - I + 1, J) = Array2D(TmpNum, J)
                Else
                    Output(MaxRow - I + 1, J) = Array2D(TmpNum, J)
                End If
            End If
                
        Next J
    Next I

EndEscape:

    '出力
    SortArray2Dby1D = Output

End Function

Private Function ConvStrToISO(InputStr As String)
'文字列を並び替え用にISOコードに変換
'20210726

    Dim Mojiretu As String
    Dim I        As Long
    Dim J        As Long
    Dim K        As Long
    Dim M        As Long
    Dim N        As Long
    Dim UniCode
    Dim UniMax   As Long: UniMax = 65536
    
    Dim StartKeta As Long: StartKeta = 20 '←←←←←←←←←←←←←←←←←←←←←←←
    Dim Kurai     As Double: Kurai = Exp(1) '←←←←←←←←←←←←←←←←←←←←←←←
    
    Dim Output As Double
    
    If InputStr = "" Then
        Output = 0
    Else
        N = Len(InputStr)
        ReDim UniCode(1 To N)
        
        Output = 0
        For I = 1 To N
            UniCode(I) = Abs(AscW(Mid(InputStr, I, 1)))
            Output = Output + ((Kurai ^ StartKeta) / (UniMax) ^ (I - 1)) * UniCode(I)
            
        Next I
    End If
    
    ConvStrToISO = Output

End Function

Private Function DimArray1DNumbers(ByRef StartNum As Long, _
                                    ByRef EndNum As Long, _
                          Optional ByVal StepNum As Long = 1) _
                                                 As Variant
'連番の入った一次元配列を定義する
'20211018
'https://www.softex-celware.com/post/dimarray1dnumbers

'引数
'StartNum ・・・最初の番号/Long型
'EndNum   ・・・最後の番号/Long型
'[StepNum]・・・連番の間隔/Long型/デフォルトは1

'返り値
'連番が入った一次元配列

    '引数のチェック
    If StepNum = 0 Then
        MsgBox "StepNumは0以外の整数を入力してください", vbExclamation
        Stop
        Exit Function
    End If
    
    '引数の修正
    If StartNum < EndNum And StepNum < 0 Then
        StepNum = -StepNum
    ElseIf StartNum > EndNum And StepNum > 0 Then
        StepNum = -StepNum
    End If
    
    '連番の作成
    Dim I      As Long
    Dim K      As Long:    K = 0
    Dim Output As Variant: ReDim Output(1 To 1)
    For I = StartNum To EndNum Step StepNum
        K = K + 1
        ReDim Preserve Output(1 To K)
        Output(K) = I
    Next I
    
    '出力
    DimArray1DNumbers = Output
    
End Function

Private Sub SortArrayQuick(ByRef KijunArray As Variant, _
                            ByRef Array123 As Variant, _
                   Optional ByRef StartNum As Long, _
                     Optional ByRef EndNum As Long)
'クイックソートで一次元配列を並び替える
'並び替え後の順番を出力するために配列「Array123」を同時に並び替える
'20210726
'20211016修正 配列の中身がオブジェクト変数でも対応

'引数
'KijunArray・・・並び替え対象の配列（一次元配列）
'Array123  ・・・「1,2,3」の値が入った一次元配列
'[StartNum]・・・再帰用の引数
'[EndNum]  ・・・再帰用の引数

    If StartNum = 0 Then
        StartNum = LBound(KijunArray, 1)
    End If
    
    If EndNum = 0 Then
        EndNum = UBound(KijunArray, 1)
    End If
    
    Dim Tmp     As Double
    Dim Counter As Double: Counter = KijunArray(WorksheetFunction.RoundDown((StartNum + EndNum) / 2, 0))
    Dim I       As Long:   I = StartNum - 1
    Dim J       As Long:   J = EndNum + 1
    
    '並び替え対象の配列の処理
    Dim Col    As Long
    Dim MinCol As Long
    Dim MaxCol As Long
    Dim Tmp2   As Variant
    
    Do
        Do
            I = I + 1
        Loop While KijunArray(I) < Counter
        
        Do
            J = J - 1
        Loop While KijunArray(J) > Counter
        
        If I >= J Then Exit Do
        Tmp = KijunArray(J)
        KijunArray(J) = KijunArray(I)
        KijunArray(I) = Tmp
        
        If IsObject(Array123(I)) Then '20211016修正
            Set Tmp2 = Array123(J)
            Set Array123(J) = Array123(I)
            Set Array123(I) = Tmp2
        Else
            Tmp2 = Array123(J)
            Array123(J) = Array123(I)
            Array123(I) = Tmp2
        End If
    Loop
    If I - StartNum > 1 Then
        Call SortArrayQuick(KijunArray, Array123, StartNum, I - 1) '再帰呼び出し
    End If
    If EndNum - J > 1 Then
        Call SortArrayQuick(KijunArray, Array123, J + 1, EndNum) '再帰呼び出し
    End If
End Sub