[arrays] VBA 배열 정렬 기능?

Program / 글쓴이

VBA의 배열에 대한 적절한 정렬 구현을 찾고 있습니다. Quicksort가 선호됩니다. 또는 버블 또는 병합 이외의 다른 정렬 알고리즘으로 충분합니다.

이것은 MS Project 2003에서 작동하기위한 것이므로 Excel 기본 기능과 .net 관련 모든 것을 피해야합니다.

답변

봐 여기 :
편집 : 참조 된 소스 (allexperts.com)는 이후 폐쇄되었지만 관련 작성자 의견 은 다음과 같습니다.

정렬을 위해 웹에서 사용할 수있는 많은 알고리즘이 있습니다. 가장 다양하고 일반적으로 가장 빠른 것은 Quicksort 알고리즘 입니다. 아래는이를위한 기능입니다.

Lower Array Boundary (일반적으로 0) 및 Upper Array Boundary (예 : 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가 있습니다 .)

답변

다른 사람이 원한다면 ‘빠른 빠른 정렬’알고리즘을 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

답변

독일어로 설명 되어 있지만 코드는 잘 테스트 된 내부 구현입니다.

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))

답변

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

답변

자연수 (문자열) 빠른 정렬

주제에 쌓여 있습니다. 일반적으로 숫자로 문자열을 정렬하면 다음과 같은 결과를 얻을 수 있습니다.

    Text1
    Text10
    Text100
    Text11
    Text2
    Text20

하지만 정말 숫자 값을 인식하고 다음과 같이 정렬되기를 원합니다. 

    Text1
    Text2
    Text10
    Text11
    Text20
    Text100

방법은 다음과 같습니다.

노트 :

  • 오래 전에 인터넷에서 Quick Sort를 훔쳤습니다. 지금 어디인지 모르겠습니다 …
  • 인터넷에서 원래 C로 작성된 CompareNaturalNum 함수도 번역했습니다.
  • 다른 Q-Sort와의 차이점 : 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

답변

StackOverflow에 대한 관련 질문에 대한 답변으로 몇 가지 코드를 게시했습니다.

VBA에서 다차원 배열 정렬

해당 스레드의 코드 샘플은 다음과 같습니다.

  1. 벡터 배열 Quicksort;
  2. 다중 열 배열 QuickSort;
  3. BubbleSort.

Alain의 최적화 된 Quicksort는 매우 반짝입니다. 저는 기본적인 split-and-recurse를 수행했지만 위의 코드 샘플에는 중복 된 값의 중복 비교를 줄이는 ‘게이트’기능이 있습니다. 반면에 필자는 Excel 용으로 코딩하고 있으며 방어적인 코딩 방식이 조금 더 있습니다. 경고를 받으십시오. 배열에 악성 ‘Empty ()’변형이 포함되어 있으면 While .. 비교 연산자를 완수하고 무한 루프에서 코드를 트랩하십시오.

빠른 정렬 알고리즘과 모든 재귀 알고리즘은 스택을 채우고 Excel을 중단시킬 수 있습니다. 배열에 1024 개 미만의 구성원이있는 경우 기본적인 BubbleSort를 사용합니다.

Public Sub QuickSortArray (ByRef SortArray As Variant, _
                                옵션 lngMin As Long = -1, _
                                lngMax As Long 옵션 = -1, _
                                선택적 lngColumn As Long = 0)
On Error Resume Next 

'2 차원 배열 정렬

'샘플 사용법 : 열 3의 내용을 기준으로 arrData 정렬
'
'QuickSortArray arrData,,, 3

'
'Posted by Jim Rech 10/20/98 Excel. Programming'Modifications 

, Nigel Heffernan :

''이스케이프가 비어있는 변형과 비교하지 못했습니다.
''방어 적 코딩 : 입력 확인

오랫동안 어둡게
긴 j 어둡게
Dim varMid As Variant
Dim arrRowTemp As Variant
긴 lngColTemp 어둡게


 IsEmpty (SortArray) 다음
     서브 종료
 End If

 InStr (TypeName (SortArray), "()") <1 If InStr (TypeName (SortArray), "()") <1 Then 'IsArray () is some broken : type name에서 대괄호를 찾습니다.
     서브 종료
 End If

 lngMin = -1이면
     lngMin = LBound (SortArray, 1)
 End If

 lngMax = -1이면
     lngMax = UBound (SortArray, 1)
 End If

 lngMin> = lngMax Then '정렬이 필요하지 않은 경우
     서브 종료
 End If


 나는 = lngMin
 j = lngMax

 varMid = 비어 있음
 varMid = SortArray ((lngMin + lngMax) \ 2, lngColumn)

 '우리는 목록 끝에'비어 있음 '및 잘못된 데이터 항목을 보냅니다.
 If IsObject (varMid) Then 'isObject (SortArray (n))를 확인하지 않습니다. varMid 가 유효한 기본 멤버 또는 속성을 선택할 수 있습니다.
     나는 = lngMax
     j = lngMin
 ElseIf IsEmpty (varMid) 다음
     나는 = lngMax
     j = lngMin
 ElseIf IsNull (varMid) 다음
     나는 = lngMax
     j = lngMin
 ElseIf varMid = ""그런 다음
     나는 = lngMax
     j = lngMin
 ElseIf varType (varMid) = vbError 그런 다음
     나는 = lngMax
     j = lngMin
 ElseIf varType (varMid)> 17 그러면
     나는 = lngMax
     j = lngMin


 I <= j 동안
 종료

     SortArray (i, lngColumn) <varMid 및 i <lngMax
         나는 = 나는 + 1
     향하게 하다

     varMid <SortArray (j, lngColumn) 및 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 지우기

         나는 = 나는 + 1
         J = J - 1 

     최종면 


 나아가 다

 If (lngMin <j) Then Call QuickSortArray (SortArray, lngMin, j, lngColumn)
 If (i <lngMax) Then Call QuickSortArray (SortArray, i, lngMax, lngColumn) 


End Sub

답변

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

누군가 다른 버전의 Office를 사용하여 테스트하는 경우 문제가 있으면 여기에 게시하십시오.