VBAの配列ソート関数?
-
02-07-2019 - |
質問
VBA での配列の適切な並べ替え実装を探しています。クイックソートの方が望ましいでしょう。またはその他 ソートアルゴリズム バブルまたはマージ以外では十分です。
これは MS Project 2003 で動作するため、Excel のネイティブ関数や .net 関連の関数は避けてください。
解決
ご覧くださいこちら :
編集:参照元のソース(allexperts.com)はその後閉鎖されましたが、関連する作成者のコメント:
ソートには、ウェブ上で利用可能な多くのアルゴリズムがあります。最も汎用性が高く、通常最も高速なのは、 クイックソートアルゴリズム です。以下はそのための関数です。
下位配列境界(通常は
0
)および Upper Array Boundary (つまり、UBound(myArray)
。)例 :
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 こちらがあります。)
他のヒント
「高速クイックソート」アルゴリズムを必要に応じて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
説明はドイツ語ですが、コードは十分にテストされており、実装の配置:
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))
StackOverflow の関連質問への回答としてコードを投稿しました。
このスレッドのコード サンプルには次のものが含まれます。
- ベクトル配列のクイックソート。
- 複数列配列の QuickSort。
- バブルソート。
Alain の最適化された Quicksort は非常に優れています。基本的な分割と再帰を実行しただけですが、上記のコード サンプルには、重複した値の冗長な比較を削減する「ゲート」関数が含まれています。一方、私は Excel 用のコードを作成していますが、防御的なコーディングにはもう少し工夫が必要です。配列に有害な 'Empty()' バリアントが含まれている場合は、これが必要になることに注意してください。これにより While.. 。比較演算子を編集して、コードを無限ループに閉じ込めます。
クイックソート アルゴリズムや再帰的アルゴリズムは、スタックをいっぱいにして 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
'Sort a 2-Dimensional array
' Sample Usage: sort arrData by the contents of column 3 ' ' QuickSortArray arrData, , , 3
' 'Posted by Jim Rech 10/20/98 Excel.Programming
'Modifications, Nigel Heffernan:
' ' Escape failed comparison with empty variant ' ' Defensive coding: check inputs
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() is somewhat broken: Look for brackets in the type name 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 ' no sorting required Exit Sub End If
i = lngMin j = lngMax
varMid = Empty varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)
' We send 'Empty' and invalid data items to the end of the list: If IsObject(varMid) Then ' note that we don't check isObject(SortArray(n)) - varMid かもしれない pick up a valid default member or property 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
While i <= j
While SortArray(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
' Swap the rows 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) Next lngColTemp Erase 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
自然数(文字列)クイックソート
トピックに重ねるだけです。 通常、文字列を数字で並べ替えると、次のようになります:
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
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
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
他のバージョンのオフィスを使用して誰かがこれをテストする場合、問題がある場合はここに投稿してください。
この配列並べ替えコードについてどう思いますか。実装が迅速であり、仕事をします...まだ大規模なアレイのテストは行っていません。これは、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
(テスト済みの)私のコードはより「教育されている」と思います。単純であるほど良いと仮定します。
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
これは、メモリ内でソートするために使用するものです。配列をソートするために簡単に拡張できます。
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
ヒープの実装。 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