連続する数字は「～」で、不連続な数字は「，」で連結するユーザー定義関数（回答編）

昨日は、連続する数字の結合について、設問編と称し、結果の動画だけを掲載した。
infoment.hatenablog.com

今日は、回答編を紹介する。
f:id:Infoment:20191121213622p:plain

本来ならば、「解答」とすべきところ。しかし恐らく解答は無限にあると思われ、今回は「回答」とした。
※解説については、コメントを参照ください。

Function MargeNumber(ParamArray target_range()) As String

    ' 重複除去に辞書（連想配列）を用いる。
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    
    ' 範囲指定が不連続であることを考慮して、二重ループとしている。
    Dim myRng As Variant
    Dim r As Variant
        For Each myRng In target_range
            For Each r In myRng
                ' 重複除去が目的であるため、キー情報不問。
                ' 今回は「1」を充てている（何でもＯＫ）。
                If r.Value <> vbNullString Then
                    Dict(r.Value) = 1
                End If
            Next
        Next
    
    ' 重複除去後のキーを配列で受け取ったうえで、昇順ソート。
    Dim source_array As Variant
        source_array = Dict.Keys
        source_array = SortArray(source_array)
        
        If UBound(source_array) = 0 Then
            MargeNumber = source_array(0)
            Exit Function
        ElseIf UBound(source_array) = -1 Then
            MargeNumber = vbNullString
            Exit Function
        End If

    Dim iMin As Long: iMin = LBound(source_array)
    Dim iMax As Long: iMax = UBound(source_array)
        ' 桁の確認。最初と最後の桁が異なる場合、「～」でつなぐ。
        If Len(source_array(iMin)) <> Len(source_array(iMax)) Then
            MargeNumber = source_array(iMin) & "～" & source_array(iMax)
            Exit Function
        End If
    
    ' 共通部位桁数。
    Dim CommonDigitNumber As Long
    ' 個別部位桁数。
    Dim RemainDigitNumber As Long
    Dim i As Long
        For i = 1 To Len(source_array(iMin))
            If Mid(source_array(iMin), i, 1) <> Mid(source_array(iMax), i, 1) Then
                CommonDigitNumber = i - 1
                RemainDigitNumber = Len(source_array(iMin)) - CommonDigitNumber
                Exit For
            End If
        Next
    
    ' 個別部位を配列化。
    Dim arr() As Variant
    ReDim arr(iMin To iMax)
    Dim arr2() As Variant
    ReDim arr2(iMin To iMax)
        For i = iMin To iMax
            arr(i) = Right(source_array(i), RemainDigitNumber)
            arr2(i) = Right(source_array(i), RemainDigitNumber)
        Next
    
    Dim TempCode As String
        Select Case UBound(source_array)
            ' 要素が２個しかない場合は、「,」でつなぐ。
            Case 1
                MargeNumber = source_array(iMin) & ", " & arr(iMax)
            ' 要素が３個以上の場合。
            Case Else
                ' ２個前の要素との差が２の場合、３つの値は連続している。
                ' 従って、一つ前の要素を空白に置き換えて省略とする。
                ' 例）数字が１，２，３と並んでいる場合、１と３の差は２。
                ' 　　従って、１，２，３は必ず連続しているといえるため、
                '　　 ２を空白に置き換えて１，，３とする。
                ' ※この時、元の配列を置き換えてしまうと、その後の数字を
                ' 　確認の際、支障をきたす。そのため、元データ配列「arr」
                ' 　に加え、置き換え後の配列「arr2」を準備している。
                For i = iMin + 2 To iMax
                    If CLng(arr(i - 2)) + 2 = CLng(arr(i)) Then
                        arr2(i - 1) = vbNullString
                    End If
                Next
                
                TempCode = Join(arr2, "，")
                
                ' ２個以上「,」が連続しているということは、その前後の数が
                ' 連続していることを表す。従って、２個以上連続する「,」を
                ' まとめて「～」に置き換えている。
                Dim myReg As Object
                Set myReg = CreateObject("VBScript.RegExp")
                    myReg.Pattern = "，{2,}"
                    myReg.Global = True
                    If myReg.test(TempCode) Then
                        TempCode = myReg.Replace(TempCode, "～")
                    End If
                    
                    ' 見やすさのため、「，」の後ろに半角スペースを付したものと置換。
                    ' ※この辺りは好みなので、使用者の任意でも可。
                    MargeNumber = Left(source_array(iMin), CommonDigitNumber) & Replace(TempCode, "，", ", ")
        End Select
    
End Function

Public Function SortArray(ByVal arr As Variant, _
                       Optional sort_order As Excel.XlSortOrder = xlAscending) As Variant
    Dim aryList As Object
    Dim s As Variant
    Set aryList = CreateObject("System.Collections.ArrayList")
    
    For Each s In arr
        Call aryList.Add(s)
    Next
    
    Select Case sort_order
        Case xlAscending
            ' 昇順でソート。
            Call aryList.Sort
        Case xlDescending
            ' 昇順でソートののち、降順へ反転。
            Call aryList.Sort
            Call aryList.Reverse
    End Select
    
    SortArray = aryList.ToArray
End Function