VBA で配列の適切な並べ替えの実装を探しています。クイックソートが優先されます。または、バブルまたはマージ以外の他のソート アルゴリズムで十分です。
これは MS Project 2003 で動作するため、Excel のネイティブ関数や .net 関連のものは使用しないでください。
317812 次
13 に答える
120
ここを見てください：
編集： 参照されたソース（allexperts.com）はその後閉鎖されましたが、関連する著者のコメントは次のとおりです。
Web には、並べ替えに使用できるアルゴリズムが多数あります。最も用途が広く、通常は最速のアルゴリズムはクイックソート アルゴリズムです。以下はそのための関数です。
配列の下限(通常は
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 hereがあります。)
于 2008-09-30T09:10:21.027 に答える
22
他の誰かが望むなら、「高速クイックソート」アルゴリズムを VBA に変換しました。
Int/Long の配列で実行するように最適化しましたが、任意の同等の要素で動作するものに変換するのは簡単なはずです。
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
于 2010-12-03T16:37:58.760 に答える
12
ドイツ語で説明されていますが、コードは十分にテストされたインプレース実装です:
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))
于 2008-09-30T09:12:24.517 に答える
6
StackOverflowの関連する質問に答えるためにいくつかのコードを投稿しました：
そのスレッドのコードサンプルは次のとおりです。
- ベクトル配列クイックソート;
- 複数列の配列QuickSort;
- バブルソート。
アランの最適化されたクイックソートは非常に光沢があります。基本的な分割と再帰を実行しましたが、上記のコードサンプルには、重複した値の冗長な比較を削減する「ゲーティング」関数があります。一方、私はExcel用にコーディングしていますが、防御的なコーディングにはもう少し方法があります。注意してください。配列に有害な「Empty（）」バリアントが含まれている場合は、これが必要になります。 。比較演算子を使用して、コードを無限ループにトラップします。
クイックソートアルゴリズム（および任意の再帰アルゴリズム）がスタックを埋めてExcelをクラッシュさせる可能性があることに注意してください。配列のメンバーが1024未満の場合は、基本的なバブルソートを使用します。
Public Sub QuickSortArray（ByRef SortArray As Variant、_
オプションのlngMinAsLong = -1、_
オプションのlngMaxAsLong = -1、_
オプションのlngColumnAsLong = 0）
エラー時に次を再開
'2次元配列を並べ替える
'使用例：列3の内容でarrDataを並べ替えます
'
'QuickSortArray arrData 、、、 3
'
'投稿者JimRech10/20/98 Excel.Programming
'変更、Nigel Heffernan：
''エスケープは空のバリアントとの比較に失敗しました
''防御コーディング：入力を確認します
Dim i As Long
Dim j As Long
バリアントとしての薄暗いvarMid
バリアントとしてのDimarrRowTemp
Dim lngColTemp As Long
If IsEmpty（SortArray）Then
サブを終了
終了する場合
InStr（TypeName（SortArray）、 "（）"）<1 Then'IsArray（）がやや壊れている場合：タイプ名で角かっこを探します
サブを終了
終了する場合
lngMin=-1の場合
lngMin = LBound（SortArray、1）
終了する場合
lngMax=-1の場合
lngMax = UBound（SortArray、1）
終了する場合
lngMin> = lngMax Then'の場合、並べ替えは必要ありません
サブを終了
終了する場合
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
Wend
If i <= j Then
'行を入れ替えます
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
于 2011-02-24T12:23:30.290 に答える
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
誰かが他のバージョンのオフィスを使用してこれをテストする場合、問題がある場合はここに投稿してください。
于 2011-05-25T11:12:53.773 に答える
2
この配列の並べ替えコードについてどう思いますか。実装が速く、仕事をします...大規模な配列についてはまだテストしていません。これは 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
于 2015-11-17T11:22:25.917 に答える