• 쇼핑몰
  • 커뮤니티
  • 북마크

vb6.0/vba

[vb6.0/vba] [vb6.0/vba] 문자형(String) 배열 정렬(Sort) 함수

하나를하더라도최선을
2020.05.02 13:28 73 0

본문



Private Function ShellSortStrings(ByRef StringData() As StringAs Boolean
'-----------------------------------------------------------------------
' Procedure    : frmMain.ShellSortStrings
' Author       : GWilmot
' Date Created : 05/12/2002
'-----------------------------------------------------------------------
' Purpose      : Sorts a single dimension array of strings in ascending
'                Order, case insensitive
' Assumptions  :
' Inputs       : String Array
' Returns      : True is succeeded & sorted Array, False if not
' Effects      :
' Last Updated :
'-----------------------------------------------------------------------
Dim lsLocalData() As String    ' Holds a local copy of the data
Dim i As Long                  ' For Counter
Dim lbSwapped As Boolean       ' Flag to show that a value has been swapped
Dim lsBuffer As String         ' Holding point
 
On Error GoTo Catch
 
' Set up our local copy (that way if we error - we leave it how we found it)
ReDim lsLocalData(LBound(StringData) To UBound(StringData))
For i = LBound(StringData) To UBound(StringData)
    lsLocalData(i) = StringData(i)
Next i
 
Do
    ' Default
    lbSwapped = False
    For i = LBound(lsLocalData) To UBound(lsLocalData) - 1
        If UCase$(lsLocalData(i)) > UCase$(lsLocalData(i + 1)) Then
            ' Watch the shells....
            lsBuffer = lsLocalData(i)
            lsLocalData(i) = lsLocalData(i + 1)
            lsLocalData(i + 1= lsBuffer
            lbSwapped = True
        End If
    Next i
Loop Until Not lbSwapped
 
' Copy back
For i = LBound(StringData) To UBound(StringData)
    StringData(i) = lsLocalData(i)
Next i
 
' Set the success flag
ShellSortStrings = True
 
Finally:
    ' Clean-up
    Exit Function
 
Catch:
    ' Ignore error unless in debugmode
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ShellSortStrings of Form frmMain"
    Resume Finally
 
End Function


댓글목록 0

등록된 댓글이 없습니다.