VBA配列のソート機能？

Question

VBAの配列の適切な並べ替えの実装を探しています。クイックソートが優先されます。または、バブルまたはマージ以外のその他の ソートアルゴリズム で十分です。

これはMS Project 2003で動作するため、Excelのネイティブ機能や.net関連の機能は使用しないでください。

Answer 1

ご覧ください こちら ：
編集：参照されたソース（allexperts.com）はその後閉鎖されましたが、関連するのはここにあります author コメント：

Webには、ソート用のアルゴリズムが多数あります。最も用途が広く、最も速いのは Quicksortアルゴリズム です。以下はそのための関数です。

Lower Array Boundary（通常は0）で値の配列（文字列または数値。重要ではありません）を渡すだけで呼び出します）およびUpper Array Boundary（ie UBound(myArray)。）

例：Call QuickSort(myArray, 0, UBound(myArray))

完了すると、myArrayがソートされ、必要な処理を実行できます。
_{（ソース： archive.org ）}

Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long

  tmpLow = inLow
  tmpHi = inHi

  pivot = vArray((inLow + inHi) \ 2)

  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend

     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend

     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend

  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

これは、一次元（別名「通常」？）配列でのみ機能することに注意してください。 （動作する多次元配列QuickSort here があります。）

Answer 2

「高速クイックソート」アルゴリズムをVBAに変換しました（他の誰かが必要な場合）。

Int/Longsの配列で実行するように最適化しましたが、任意の比較可能な要素で動作するものに変換するのは簡単です。

Private Sub QuickSort(ByRef a() As Long, ByVal l As Long, ByVal r As Long)
    Dim M As Long, i As Long, j As Long, v As Long
    M = 4

    If ((r - l) > M) Then
        i = (r + l) / 2
        If (a(l) > a(i)) Then swap a, l, i '// Tri-Median Methode!'
        If (a(l) > a(r)) Then swap a, l, r
        If (a(i) > a(r)) Then swap a, i, r

        j = r - 1
        swap a, i, j
        i = l
        v = a(j)
        Do
            Do: i = i + 1: Loop While (a(i) < v)
            Do: j = j - 1: Loop While (a(j) > v)
            If (j < i) Then Exit Do
            swap a, i, j
        Loop
        swap a, i, r - 1
        QuickSort a, l, j
        QuickSort a, i + 1, r
    End If
End Sub

Private Sub swap(ByRef a() As Long, ByVal i As Long, ByVal j As Long)
    Dim T As Long
    T = a(i)
    a(i) = a(j)
    a(j) = T
End Sub

Private Sub InsertionSort(ByRef a(), ByVal lo0 As Long, ByVal hi0 As Long)
    Dim i As Long, j As Long, v As Long

    For i = lo0 + 1 To hi0
        v = a(i)
        j = i
        Do While j > lo0
            If Not a(j - 1) > v Then Exit Do
            a(j) = a(j - 1)
            j = j - 1
        Loop
        a(j) = v
    Next i
End Sub

Public Sub sort(ByRef a() As Long)
    QuickSort a, LBound(a), UBound(a)
    InsertionSort a, LBound(a), UBound(a)
End Sub

Answer 3

説明 ドイツ語ですが、コードは十分にテストされたインプレース実装です：

Private Sub QuickSort(ByRef Field() As String, ByVal LB As Long, ByVal UB As Long)
    Dim P1 As Long, P2 As Long, Ref As String, TEMP As String

    P1 = LB
    P2 = UB
    Ref = Field((P1 + P2) / 2)

    Do
        Do While (Field(P1) < Ref)
            P1 = P1 + 1
        Loop

        Do While (Field(P2) > Ref)
            P2 = P2 - 1
        Loop

        If P1 <= P2 Then
            TEMP = Field(P1)
            Field(P1) = Field(P2)
            Field(P2) = TEMP

            P1 = P1 + 1
            P2 = P2 - 1
        End If
    Loop Until (P1 > P2)

    If LB < P2 Then Call QuickSort(Field, LB, P2)
    If P1 < UB Then Call QuickSort(Field, P1, UB)
End Sub

このように呼び出されます：

Call QuickSort(MyArray, LBound(MyArray), UBound(MyArray))

Answer 4

StackOverflowの関連する質問への回答としていくつかのコードを投稿しました。

VBAでの多次元配列のソート

そのスレッドのコードサンプルには以下が含まれます。

1. ベクトル配列クイックソート。
2. 複数列の配列QuickSort。
3. BubbleSort。

Alainの最適化されたQuicksortは非常に優れています。基本的な分割と再帰を行っただけですが、上記のコードサンプルには重複した値の冗長な比較を削減する「ゲーティング」機能があります。一方、私はExcel用にコーディングしていますが、防御的なコーディングの方法にはもう少しあります-警告されますが、配列にWhileを壊す有害な「Empty（）」バリアントが含まれている場合に必要になります。 。比較演算子を実行し、コードを無限ループにトラップします。

クイックソートアルゴリズムと再帰アルゴリズムは、スタックを埋めてExcelをクラッシュさせる可能性があることに注意してください。配列のメンバーが1024未満の場合、基本的なBubbleSortを使用します。

 Public Sub QuickSortArray（ByRef SortArray As Variant、_ 
 Optional lngMin As Long = -1、_ 
 Optional lngMax As Long = -1、_ 
 Optional lngColumn As Long = 0）
 On Error Resume Next

 '2次元配列の並べ替え

 '使用例：列3 
' 
 'QuickSortArray arrData、、、3の内容でarrDataをソートします

 '
'投稿者Jim Rech 10/20/98 Excel.Programming

 'Modifications、Nigel Heffernan：

 ''エスケープは空のバリアントとの比較に失敗しました
 ''防御コーディング：入力をチェック

 Dim i As Long 
 Dim j As Long 
 Dim varMid As Variant 
 Dim arrRowTemp As Variant 
 Dim lngColTemp As Long


 If IsEmpty（SortArray）Then 
 Exit Sub 
 End If

 If InStr（TypeName（SortArray）、 "（）"）<1 Then 'IsArray（）はやや壊れています：型名の括弧を探します
 Exit Sub 
 End If

 If lngMin = -1 Then 
 lngMin = LBound（SortArray、1）
 End If
 
 If lngMax = -1 Then 
 lngMax = UBound（SortArray、1）
 End If
 
 If lngMin> = lngMax Then '並べ替えは不要です
 Exit Sub 
 End If


 i = lngMin 
 j = lngMax

 varMid = Empty 
 varMid = SortArray（（lngMin + lngMax）\ 2、lngColumn）

 'リストの最後に' Empty 'および無効なデータ項目を送信します。
 If IsObject（varMid）Then' isObject（SortArray（n））-varMidをチェックしないことに注意してくださいmight有効なデフォルトのメンバーまたはプロパティを選択する
 i = lngMax 
 j = lngMin 
 ElseIf IsEmpty （varMid）Then 
 i = lngMax 
 j = lngMin 
 ElseIf IsNull（varMid）Then 
 i = lngMax 
 j = lngMin 
 ElseIf varMid = "" Then 
 i = lngMax 
 j = lngMin 
 ElseIf varType（varMid）= vbError Then 
 i = lngMax 
 j = lngMin 
 ElseIf varType（varMid）> 17 Then 
 i = lngMax 
 j = lngMin 
 End If


一方、i <= j

 While ArrayArray（i、lngColumn）<varMid And i <lngMax 
 i = i + 1 
 Wend

 While varMid <SortArray（j、lngColumn）And j> lngMin 
 j = j-1 
 Wend


 If i <= j Then

 '行をスワップします
 ReDim arrRowTemp（LBound（SortArray、2）To UBound（SortArray、2））
 For lngColTemp = LBound（SortArray、2）To UBound（SortArray、 2）
 arrRowTemp（lngColTemp）= SortArray（i、lngColTemp）
 SortArray（i、lngColTemp）= SortArray（j、lngColTemp）
 SortArray（j、lngColTemp）= arrRowTemp（ lngColTemp）
次のlngColTemp 
 arrRowTempを消去します

 i = i + 1 
 j = j-1

 End If


ウェンド

 If（lngMin <j）Then Call QuickSortArray（SortArray、lngMin、j、lngColumn）
 If（i <lngMax）Then Call QuickSortArray（SortArray、i、lngMax、lngColumn）

 
サブ終了

Answer 5

自然数（文字列）クイックソート

トピックに重ねるだけです。通常、文字列を数字で並べ替えると、次のようになります。

    Text1
    Text10
    Text100
    Text11
    Text2
    Text20

しかし、あなたは本当にそれが数値を認識し、次のようにソートされることを望みます

    Text1
    Text2
    Text10
    Text11
    Text20
    Text100

方法は次のとおりです...

注意：

• 私はずっと前にインターネットからクイックソートを盗みました、今どこで...
• 元々はインターネットでCで書かれたCompareNaturalNum関数も翻訳しました。
• 他のQ-Sortsとの違い：BottomTemp = TopTempの場合、値を交換しません

自然数クイックソート

Public Sub QuickSortNaturalNum(strArray() As String, intBottom As Integer, intTop As Integer)
Dim strPivot As String, strTemp As String
Dim intBottomTemp As Integer, intTopTemp As Integer

    intBottomTemp = intBottom
    intTopTemp = intTop

    strPivot = strArray((intBottom + intTop) \ 2)

    Do While (intBottomTemp <= intTopTemp)
        ' < comparison of the values is a descending sort
        Do While (CompareNaturalNum(strArray(intBottomTemp), strPivot) < 0 And intBottomTemp < intTop)
            intBottomTemp = intBottomTemp + 1
        Loop
        Do While (CompareNaturalNum(strPivot, strArray(intTopTemp)) < 0 And intTopTemp > intBottom) '
            intTopTemp = intTopTemp - 1
        Loop
        If intBottomTemp < intTopTemp Then
            strTemp = strArray(intBottomTemp)
            strArray(intBottomTemp) = strArray(intTopTemp)
            strArray(intTopTemp) = strTemp
        End If
        If intBottomTemp <= intTopTemp Then
            intBottomTemp = intBottomTemp + 1
            intTopTemp = intTopTemp - 1
        End If
    Loop

    'the function calls itself until everything is in good order
    If (intBottom < intTopTemp) Then QuickSortNaturalNum strArray, intBottom, intTopTemp
    If (intBottomTemp < intTop) Then QuickSortNaturalNum strArray, intBottomTemp, intTop
End Sub

自然数比較（クイックソートで使用）

Function CompareNaturalNum(string1 As Variant, string2 As Variant) As Integer
'string1 is less than string2 -1
'string1 is equal to string2 0
'string1 is greater than string2 1
Dim n1 As Long, n2 As Long
Dim iPosOrig1 As Integer, iPosOrig2 As Integer
Dim iPos1 As Integer, iPos2 As Integer
Dim nOffset1 As Integer, nOffset2 As Integer

    If Not (IsNull(string1) Or IsNull(string2)) Then
        iPos1 = 1
        iPos2 = 1
        Do While iPos1 <= Len(string1)
            If iPos2 > Len(string2) Then
                CompareNaturalNum = 1
                Exit Function
            End If
            If isDigit(string1, iPos1) Then
                If Not isDigit(string2, iPos2) Then
                    CompareNaturalNum = -1
                    Exit Function
                End If
                iPosOrig1 = iPos1
                iPosOrig2 = iPos2
                Do While isDigit(string1, iPos1)
                    iPos1 = iPos1 + 1
                Loop

                Do While isDigit(string2, iPos2)
                    iPos2 = iPos2 + 1
                Loop

                nOffset1 = (iPos1 - iPosOrig1)
                nOffset2 = (iPos2 - iPosOrig2)

                n1 = Val(Mid(string1, iPosOrig1, nOffset1))
                n2 = Val(Mid(string2, iPosOrig2, nOffset2))

                If (n1 < n2) Then
                    CompareNaturalNum = -1
                    Exit Function
                ElseIf (n1 > n2) Then
                    CompareNaturalNum = 1
                    Exit Function
                End If

                ' front padded zeros (put 01 before 1)
                If (n1 = n2) Then
                    If (nOffset1 > nOffset2) Then
                        CompareNaturalNum = -1
                        Exit Function
                    ElseIf (nOffset1 < nOffset2) Then
                        CompareNaturalNum = 1
                        Exit Function
                    End If
                End If
            ElseIf isDigit(string2, iPos2) Then
                CompareNaturalNum = 1
                Exit Function
            Else
                If (Mid(string1, iPos1, 1) < Mid(string2, iPos2, 1)) Then
                    CompareNaturalNum = -1
                    Exit Function
                ElseIf (Mid(string1, iPos1, 1) > Mid(string2, iPos2, 1)) Then
                    CompareNaturalNum = 1
                    Exit Function
                End If

                iPos1 = iPos1 + 1
                iPos2 = iPos2 + 1
            End If
        Loop
        ' Everything was the same so far, check if Len(string2) > Len(String1)
        ' If so, then string1 < string2
        If Len(string2) > Len(string1) Then
            CompareNaturalNum = -1
            Exit Function
        End If
    Else
        If IsNull(string1) And Not IsNull(string2) Then
            CompareNaturalNum = -1
            Exit Function
        ElseIf IsNull(string1) And IsNull(string2) Then
            CompareNaturalNum = 0
            Exit Function
        ElseIf Not IsNull(string1) And IsNull(string2) Then
            CompareNaturalNum = 1
            Exit Function
        End If
    End If
End Function

isDigit（CompareNaturalNumで使用）

Function isDigit(ByVal str As String, pos As Integer) As Boolean
Dim iCode As Integer
    If pos <= Len(str) Then
        iCode = Asc(Mid(str, pos, 1))
        If iCode >= 48 And iCode <= 57 Then isDigit = True
    End If
End Function

Answer 6

Dim arr As Object
Dim InputArray

'Creating a array list
Set arr = CreateObject("System.Collections.ArrayList")

'String
InputArray = Array("d", "c", "b", "a", "f", "e", "g")

'number
'InputArray = Array(6, 5, 3, 4, 2, 1)

' adding the elements in the array to array_list
For Each element In InputArray
    arr.Add element
Next

'sorting happens
arr.Sort

'Converting ArrayList to an array
'so now a sorted array of elements is stored in the array sorted_array.

sorted_array = arr.toarray

Answer 7

Excelベースのソリューションは必要ありませんでしたが、今日同じ問題があり、他のOfficeアプリケーション機能を使用してテストしたいので、以下の関数を作成しました。

制限事項：

• 2次元配列。
• ソートキーとして最大3列。
• excelに依存します。

Visio 2010からExcel 2010を呼び出してテスト済み

---

Option Base 1


Private Function sort_array_2D_Excel(array_2D, array_sortkeys, Optional array_sortorders, Optional tag_header As String = "Guess", Optional tag_matchcase As String = "False")

'   Dependencies: Excel; Tools > References > Microsoft Excel [Version] Object Library

    Dim Excel_application As Excel.Application
    Dim Excel_workbook As Excel.Workbook
    Dim Excel_worksheet As Excel.Worksheet

    Set Excel_application = CreateObject("Excel.Application")

    Excel_application.Visible = True
    Excel_application.ScreenUpdating = False
    Excel_application.WindowState = xlNormal

    Set Excel_workbook = Excel_application.Workbooks.Add
    Excel_workbook.Activate

    Set Excel_worksheet = Excel_workbook.Worksheets.Add
    Excel_worksheet.Activate
    Excel_worksheet.Visible = xlSheetVisible

    Dim Excel_range As Excel.Range
    Set Excel_range = Excel_worksheet.Range("A1").Resize(UBound(array_2D, 1) - LBound(array_2D, 1) + 1, UBound(array_2D, 2) - LBound(array_2D, 2) + 1)
    Excel_range = array_2D


    For i_sortkey = LBound(array_sortkeys) To UBound(array_sortkeys)

        If IsNumeric(array_sortkeys(i_sortkey)) Then
            sortkey_range = Chr(array_sortkeys(i_sortkey) + 65 - 1) & "1"
            Set array_sortkeys(i_sortkey) = Excel_worksheet.Range(sortkey_range)

        Else
            MsgBox "Error in sortkey parameter:" & vbLf & "array_sortkeys(" & i_sortkey & ") = " & array_sortkeys(i_sortkey) & vbLf & "Terminating..."
            End

        End If

    Next i_sortkey


    For i_sortorder = LBound(array_sortorders) To UBound(array_sortorders)
        Select Case LCase(array_sortorders(i_sortorder))
            Case "asc"
                array_sortorders(i_sortorder) = XlSortOrder.xlAscending
            Case "desc"
                array_sortorders(i_sortorder) = XlSortOrder.xlDescending
            Case Else
                array_sortorders(i_sortorder) = XlSortOrder.xlAscending
        End Select
    Next i_sortorder

    Select Case LCase(tag_header)
        Case "yes"
            tag_header = Excel.xlYes
        Case "no"
            tag_header = Excel.xlNo
        Case "guess"
            tag_header = Excel.xlGuess
        Case Else
            tag_header = Excel.xlGuess
    End Select

    Select Case LCase(tag_matchcase)
        Case "true"
            tag_matchcase = True
        Case "false"
            tag_matchcase = False
        Case Else
            tag_matchcase = False
    End Select


    Select Case (UBound(array_sortkeys) - LBound(array_sortkeys) + 1)
        Case 1
            Call Excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Header:=tag_header, MatchCase:=tag_matchcase)
        Case 2
            Call Excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Key2:=array_sortkeys(2), Order2:=array_sortorders(2), Header:=tag_header, MatchCase:=tag_matchcase)
        Case 3
            Call Excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Key2:=array_sortkeys(2), Order2:=array_sortorders(2), Key3:=array_sortkeys(3), Order3:=array_sortorders(3), Header:=tag_header, MatchCase:=tag_matchcase)
        Case Else
            MsgBox "Error in sortkey parameter:" & vbLf & "Maximum number of sort columns is 3!" & vbLf & "Currently passed: " & (UBound(array_sortkeys) - LBound(array_sortkeys) + 1)
            End
    End Select


    For i_row = 1 To Excel_range.Rows.Count

        For i_column = 1 To Excel_range.Columns.Count

            array_2D(i_row, i_column) = Excel_range(i_row, i_column)

        Next i_column

    Next i_row


    Excel_workbook.Close False
    Excel_application.Quit

    Set Excel_worksheet = Nothing
    Set Excel_workbook = Nothing
    Set Excel_application = Nothing


    sort_array_2D_Excel = array_2D


End Function

---

これは、関数をテストする方法の例です。

Private Sub test_sort()

    array_unsorted = dim_sort_array()

    Call msgbox_array(array_unsorted)

    array_sorted = sort_array_2D_Excel(array_unsorted, Array(2, 1, 3), Array("desc", "", "asdas"), "yes", "False")

    Call msgbox_array(array_sorted)

End Sub


Private Function dim_sort_array()

    Dim array_unsorted(1 To 5, 1 To 3) As String

    i_row = 0

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "Column1": array_unsorted(i_row, 2) = "Column2": array_unsorted(i_row, 3) = "Column3"

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "OR": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "XOR": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "NOT": array_unsorted(i_row, 2) = "B": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "AND": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    dim_sort_array = array_unsorted

End Function


Sub msgbox_array(array_2D, Optional string_info As String = "2D array content:")

    msgbox_string = string_info & vbLf

    For i_row = LBound(array_2D, 1) To UBound(array_2D, 1)

        msgbox_string = msgbox_string & vbLf & i_row & vbTab

        For i_column = LBound(array_2D, 2) To UBound(array_2D, 2)

            msgbox_string = msgbox_string & array_2D(i_row, i_column) & vbTab

        Next i_column

    Next i_row

    MsgBox msgbox_string

End Sub

---

他のバージョンのオフィスを使用して誰かがこれをテストする場合、問題がある場合はここに投稿してください。

Answer 8

この配列ソートコードについて何と言うでしょうか。実装が迅速であり、仕事をします...まだ大規模なアレイのテストは行っていません。これは、1次元配列に対して機能します。多次元の追加値については、再配置マトリックスを作成する必要があります（最初の配列よりも1次元少ない）。

       For AR1 = LBound(eArray, 1) To UBound(eArray, 1)
            eValue = eArray(AR1)
            For AR2 = LBound(eArray, 1) To UBound(eArray, 1)
                If eArray(AR2) < eValue Then
                    eArray(AR1) = eArray(AR2)
                    eArray(AR2) = eValue
                    eValue = eArray(AR1)
                End If
            Next AR2
        Next AR1

Answer 9

ヒープソート 実装。 O（n log（n））（平均および最悪の場合の両方）、所定の場所、 不安定 ソートアルゴリズム。

Call HeapSort(A)で使用します。ここで、AはOption Base 1を使用したバリアントの1次元配列です。

Sub SiftUp(A() As Variant, I As Long)
    Dim K As Long, P As Long, S As Variant
    K = I
    While K > 1
        P = K \ 2
        If A(K) > A(P) Then
            S = A(P): A(P) = A(K): A(K) = S
            K = P
        Else
            Exit Sub
        End If
    Wend
End Sub

Sub SiftDown(A() As Variant, I As Long)
    Dim K As Long, L As Long, S As Variant
    K = 1
    Do
        L = K + K
        If L > I Then Exit Sub
        If L + 1 <= I Then
            If A(L + 1) > A(L) Then L = L + 1
        End If
        If A(K) < A(L) Then
            S = A(K): A(K) = A(L): A(L) = S
            K = L
        Else
            Exit Sub
        End If
    Loop
End Sub

Sub HeapSort(A() As Variant)
    Dim N As Long, I As Long, S As Variant
    N = UBound(A)
    For I = 2 To N
        Call SiftUp(A, I)
    Next I
    For I = N To 2 Step -1
        S = A(I): A(I) = A(1): A(1) = S
        Call SiftDown(A, I - 1)
    Next
End Sub

Answer 10

これは、メモリ内でソートするために使用するものです-配列をソートするために簡単に拡張できます。

Sub sortlist()

    Dim xarr As Variant
    Dim yarr As Variant
    Dim zarr As Variant

    xarr = Sheets("sheet").Range("sing col range")
    ReDim yarr(1 To UBound(xarr), 1 To 1)
    ReDim zarr(1 To UBound(xarr), 1 To 1)

    For n = 1 To UBound(xarr)
        zarr(n, 1) = 1
    Next n

    For n = 1 To UBound(xarr) - 1
        y = zarr(n, 1)
        For a = n + 1 To UBound(xarr)
            If xarr(n, 1) > xarr(a, 1) Then
                y = y + 1
            Else
                zarr(a, 1) = zarr(a, 1) + 1
            End If
        Next a
        yarr(y, 1) = xarr(n, 1)
    Next n

    y = zarr(UBound(xarr), 1)
    yarr(y, 1) = xarr(UBound(xarr), 1)

    yrng = "A1:A" & UBound(yarr)
    Sheets("sheet").Range(yrng) = yarr

End Sub

Answer 11

単純であるほど良いと仮定すると、（テスト済みの）私のコードはより「教育された」と思います。

Option Base 1

'Function to sort an array decscending
Function SORT(Rango As Range) As Variant
    Dim check As Boolean
    check = True
    If IsNull(Rango) Then
        check = False
    End If
    If check Then
        Application.Volatile
        Dim x() As Variant, n As Double, m As Double, i As Double, j As Double, k As Double
        n = Rango.Rows.Count: m = Rango.Columns.Count: k = n * m
        ReDim x(n, m)
        For i = 1 To n Step 1
            For j = 1 To m Step 1
                x(i, j) = Application.Large(Rango, k)
                k = k - 1
            Next j
        Next i
        SORT = x
    Else
        Exit Function
    End If
End Function