VBA配列ソート機能？

83

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

これはMSProject 2003で機能するため、Excelのネイティブ関数や.netに関連するものはすべて避ける必要があることに注意してください。

arrays  sorting  vba  vb6  ms-project 
— マーク・ノルド
ソース
3
ここを見てみると面白いかもしれません：rosettacode.org/wiki/Sorting_algorithms/Quicksort#VBA
— MjrKusanagi 2014
マージソートが好きではないのはなぜですか？
— jwg 2016年

回答:

101

ここを見てください：
編集： 参照されているソース（allexperts.com）はその後閉鎖されましたが、関連する著者のコメントは次のとおりです。

ソートのためにウェブ上で利用可能な多くのアルゴリズムがあります。最も用途が広く、通常最も速いのはクイックソートアルゴリズムです。以下はそのための関数です。

値の配列（文字列または数値。重要ではありません）を下位配列境界（通常0）および上位配列境界（つまり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

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

— ホルヘ・フェレイラ
ソース
2
これは、重複を処理する場合のわずかに高速な実装です。おそらく\ 2が原因です。良い答え：）
— Mark Nold 2008年
どうもありがとう！2500エントリのデータセットで挿入ソートを使用していましたが、正しくソートするには約22秒かかりました。今では1秒以内に完了します。これは奇跡です。;）
— djule5 2011年
この関数の効果は、常に最初の項目をソースから宛先の最後の位置に移動し、配列の残りの部分を適切にソートすることのようです。
— ジャスミン
9年以上経った今でも素晴らしい解決策です。しかし残念ながら、参照ページallexperts.comはもはや存在しない...
— Egalth
2
@ Egalth-元のソースにあった情報で質問を更新しました
— ashleedawg 2018年
16

他の誰かが望むなら、私は「高速クイックソート」アルゴリズムを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
— アラン
ソース
ちなみに、アルゴリズムに対するコメントは次のとおりです。著者のJamesGoslingとKevinA。Smithは、Denis AhrensによるTriMedianとInsertionSortで拡張し、Robert Sedgewickからのすべてのヒントを使用して、4より短いリストにはTriMedianとInsertionSortを使用しています。 CARHoareのクイックソートアルゴリズムの汎用バージョン。これは、すでにソートされている配列、および重複キーを持つ配列を処理します。
— アラン
17
私がこれを投稿した神に感謝します。3時間後、私は墜落して1日の仕事を失いましたが、少なくともこれを回復することができます。今、それは仕事中のカルマです。コンピュータは難しいです。
— アラン
11

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

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))
— コンラッド・ルドルフ
ソース
1
ByVal Field（）でエラーが発生し、デフォルトのByRefを使用する必要があります。
— マークノルド2008年
@ MarkNold-うん私も
— リチャードH
byvalはフィールド値の変更と保存を許可しないため、とにかくbyrefです。渡された引数にbyvalがどうしても必要な場合は、文字列の代わりにバリアントを使用し、ブレーキなし（）を使用します。
— Patrick Lepelletier 2016年
@Patrickええ、どうやってそこに入ったのか、私にはよくわかりませんByVal。混乱はおそらく、VB.NETではByValここで機能するという事実から来ました（ただし、これはVB.NETでは異なる方法で実装されます）。
— Konrad Rudolph
9 
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
— プラサンドクマール
ソース
これを関数に変換して、出力例を表示できますか？速度について何かアイデアはありますか？
— not2qubit 2017年
2
@Ansは編集を拒否しました-変換に関するすべてのコメントを削除したため、コメントされていないコードのみが（関数として）残されました。短さは素晴らしいですが、この答えの他の読者の「理解可能性」を減らすときはそうではありません。
— PatrickArtner18年
@Patrick Artner特にここに投稿されている他の例と比較すると、コードは非常に単純です。ここで最も簡単な例を探している人は、関連するコードだけを残しておけば、これをより早く見つけることができると思います。
— アンス
すばらしい答えになるでしょうが、おそらくSystem.Collections.ArrayList32ビットと64ビットのWindowsの異なる場所にある問題に対処する必要があります。私の32ビットExcelは、32ビットWinが格納する場所で暗黙的にそれを見つけようとしますが、64ビットWinがあるため、問題もあります：/エラーが発生します-2146232576 (80131700)。
— zygD 2018
プラサンドありがとう！他のブルートフォースアプローチの巧妙な代替手段。
— pstraton
7

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

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

    Text1
    Text10
    Text100
    Text11
    Text2
    Text20

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

    Text1
    Text2
    Text10
    Text11
    Text20
    Text100

これがそれを行う方法です...

注意：

  • 私はずっと前にインターネットからクイックソートを盗みました、今どこにいるのかわかりません...
  • もともとインターネットからCで書かれたCompareNaturalNum関数も翻訳しました。
  • 他のQソートとの違い：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
— Profex
ソース
ニース-私はNaturalNumberソートが好きです-これをオプションとして追加する必要があります
— Mark Nold 2016年
6

StackOverflowの関連する質問に答えるためにいくつかのコードを投稿しました：

VBAで多次元配列を並べ替える

そのスレッドのコードサンプルは次のとおりです。

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

アランの最適化されたクイックソートは非常に光沢があります。基本的な分割と再帰を実行しましたが、上記のコードサンプルには、重複した値の冗長な比較を削減する「ゲーティング」関数があります。一方、私はExcel用にコーディングしていますが、防御的なコーディングにはもう少し方法があります。注意してください。配列に有害な「Empty（）」バリアントが含まれていると、Whileが壊れてしまいます。 。比較演算子を使用して、コードを無限ループに閉じ込めます。

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

Public Sub QuickSortArray（ByRef SortArray As Variant、_
                                オプションのlngMinAs Long = -1、_ 
                                オプションのlngMaxAs Long = -1、_ 
                                オプションのlngColumnAs Long = 0）
エラー時再開次へ

'2次元配列を並べ替える

'使用例：列3の内容でarrDataを並べ替えます
'
'QuickSortArray arrData 、、、 3

'
'投稿者JimRech 10/20/98 Excel.Programming 

'変更、Nigel Heffernan：

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

Dim i As Long
Dim j As Long
バリアントとしての薄暗いvarMid
バリアントとしてのDimarrRowTemp
Dim lngColTemp As Long


 If IsEmpty（SortArray）Then
     サブを終了
 End If

 InStr（TypeName（SortArray）、 "（）"）<1の場合 'IsArray（）が多少壊れています：型名で角かっこを探します
     サブを終了
 End If

 lngMin = -1の場合
     lngMin = LBound（SortArray、1）
 End If
 
 lngMax = -1の場合
     lngMax = UBound（SortArray、1）
 End If
 
 lngMin> = lngMax Then 'の場合、並べ替えは必要ありません
     サブを終了
 End If


 i = lngMin
 j = lngMax

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

 '空の'および無効なデータ項目をリストの最後に送信します。
 If IsObject（varMid）Then'isObject（SortArray（n））をチェックしないことに注意してください-varMid は有効なデフォルトのメンバーまたはプロパティを可能性があります
     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


 i <= jの
 場合に終了

     SortArray（i、lngColumn）<varMid And i <lngMax
         i = i + 1
     ヴェンド

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


     I <= jの場合に
     WendThen

         '行を交換します
         ReDim arrRowTemp（LBound（SortArray、2）To UBound（SortArray、2））
         lngColTemp = LBound（SortArray、2）の場合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 


 Wend

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

 
End Sub

— Nigel Heffernan
ソース
2

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

制限：

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

Visio2010からExcel2010を呼び出すことをテストしました

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

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

— lucas0x7B
ソース
1
これmsgbox_array()は、デバッグ中に2次元配列をすばやく検査するのに役立つ関数であることを忘れました。
— lucas0x7B 2011年
1

この配列ソートコードについてどう思いますか。実装は迅速で、仕事はできます...まだ大きなアレイのテストは行っていません。これは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
— ジャレック
ソース
5
これはバブルソートです。OPはバブル以外のものを求めました。
— Michiel van der Blonk 2015年
0

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

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
— モレノ
ソース
3
これはどんな種類ですか？そして、なぜそれは「教育を受けた」と言うのですか？
— not2qubit 2017年
コードを読むと、2次元配列全体（Excelシートから取得）を配列全体（特定の次元ではない）で「ソート」しているように見えます。したがって、値はディメンションインデックスを変更します。そして、結果はシートに戻されます。
— zygD 2018
1
コードは単純なケースでは機能するかもしれませんが、このコードには多くの問題があります。私が最初に気付くのは、どこでもではDoubleなくの使用ですLong。次に、範囲に複数の領域があるかどうかは考慮されません。長方形の並べ替えは役に立たないようです。もちろん、OPが要求したものでもありません（具体的には、ネイティブのExcel / .Netソリューションはないと言っています）。また、単純であるほど「教育を受けている」と見なす場合、組み込みRange.Sort()関数を使用するのが最善ではないでしょうか。
— Profex 2018年
0

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

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
— Reged
ソース
0

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

と一緒に使用しますCall HeapSort(A)。ここAで、はバリアントの1次元配列で、はOption Base 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
0

@Prasand Kumar、Prasandの概念に基づく完全なソートルーチンは次のとおりです。

Public Sub ArrayListSort(ByRef SortArray As Variant)
    '
    'Uses the sort capabilities of a System.Collections.ArrayList object to sort an array of values of any simple
    'data-type.
    '
    'AUTHOR: Peter Straton
    '
    'CREDIT: Derived from Prasand Kumar's post at: /programming/152319/vba-array-sort-function
    '
    '*************************************************************************************************************

    Static ArrayListObj As Object
    Dim i As Long
    Dim LBnd As Long
    Dim UBnd As Long

    LBnd = LBound(SortArray)
    UBnd = UBound(SortArray)

    'If necessary, create the ArrayList object, to be used to sort the specified array's values

    If ArrayListObj Is Nothing Then
        Set ArrayListObj = CreateObject("System.Collections.ArrayList")
    Else
        ArrayListObj.Clear  'Already allocated so just clear any old contents
    End If

    'Add the ArrayList elements from the array of values to be sorted. (There appears to be no way to do this
    'using a single assignment statement.)

    For i = LBnd To UBnd
        ArrayListObj.Add SortArray(i)
    Next i

    ArrayListObj.Sort   'Do the sort

    'Transfer the sorted ArrayList values back to the original array, which can be done with a single assignment
    'statement.  But the result is always zero-based so then, if necessary, adjust the resulting array to match
    'its original index base.

    SortArray = ArrayListObj.ToArray
    If LBnd <> 0 Then ReDim Preserve SortArray(LBnd To UBnd)
End Sub
— プストラトン
ソース
0

やや関連性がありますが、高度なデータ構造（辞書など）が私の環境で機能していないため、ネイティブのExcelVBAソリューションも探していました。以下は、VBAのバイナリツリーを介した並べ替えを実装しています。

  • 配列が1つずつ入力されていると想定します
  • 重複を削除します
  • "0|2|3|4|9"分割できる分離された文字列（）を返します。

任意に選択された範囲に対して選択された行の生のソートされた列挙を返すために使用しました

Private Enum LeafType: tEMPTY: tTree: tValue: End Enum
Private Left As Variant, Right As Variant, Center As Variant
Private LeftType As LeafType, RightType As LeafType, CenterType As LeafType
Public Sub Add(x As Variant)
    If CenterType = tEMPTY Then
        Center = x
        CenterType = tValue
    ElseIf x > Center Then
        If RightType = tEMPTY Then
            Right = x
            RightType = tValue
        ElseIf RightType = tTree Then
            Right.Add x
        ElseIf x <> Right Then
            curLeaf = Right
            Set Right = New TreeList
            Right.Add curLeaf
            Right.Add x
            RightType = tTree
        End If
    ElseIf x < Center Then
        If LeftType = tEMPTY Then
            Left = x
            LeftType = tValue
        ElseIf LeftType = tTree Then
            Left.Add x
        ElseIf x <> Left Then
            curLeaf = Left
            Set Left = New TreeList
            Left.Add curLeaf
            Left.Add x
            LeftType = tTree
        End If
    End If
End Sub
Public Function GetList$()
    Const sep$ = "|"
    If LeftType = tValue Then
        LeftList$ = Left & sep
    ElseIf LeftType = tTree Then
        LeftList = Left.GetList & sep
    End If
    If RightType = tValue Then
        RightList$ = sep & Right
    ElseIf RightType = tTree Then
        RightList = sep & Right.GetList
    End If
    GetList = LeftList & Center & RightList
End Function

'Sample code
Dim Tree As new TreeList
Tree.Add("0")
Tree.Add("2")
Tree.Add("2")
Tree.Add("-1")
Debug.Print Tree.GetList() 'prints "-1|0|2"
sortedList = Split(Tree.GetList(),"|")
— q335r49
ソース
弊社のサイトを使用することにより、あなたは弊社のクッキーポリシーおよびプライバシーポリシーを読み、理解したものとみなされます。
Licensed under cc by-sa 3.0 with attribution required.