removedu.bas

数值排序

Attribute VB_Name = "basRemoveDupes"
' ---------------------------------------------------------
' RemoveDupes
'
' Author:     Kenneth Ives      [e-mail]
'
' This is freeware.  Use as you see fit.
' Compiled with VB 5.0 (Sp3)
'
' If you want to remove the duplicates from a sorted
' list box, this module will work just fine.  Be sure
' to load your data into an array before passing it
' to the RemoveDupes routine.
'
' If there is a better way, I am always open to change.
' ---------------------------------------------------------
Option Explicit

Private Function IsInArray(vData As Variant, vSrchData As Variant, lStart As Long) As Boolean
    
' ---------------------------------------------------------
' Author:     Kenneth Ives      [e-mail]
'
' Syntax:     IsInArray tmpArray(), vSrchData, lStart
'
' Parameters:
'     vData  - A variant pointing to an array to be
'              parsed for duplicate values
'
'  vSrchData - A value in the array to look for
'
'    lStart  - The starting point in the array
'
' We want to determine if an item is already
' in this array.  We do this by looping through and
' comparing the sSrchData with each item in the array.
' Since we started with the next item in the array, we
' should not have a duplicate.
' ---------------------------------------------------------

' ---------------------------------------------------------
' Test to see if an array was passed
' ---------------------------------------------------------
  If Not IsArray(vData) Then Exit Function

' ---------------------------------------------------------
' Define local variable
' ---------------------------------------------------------
  Dim Hi As Long
    
' ---------------------------------------------------------
' upper end of the array
' ---------------------------------------------------------
  Hi = UBound(vData)
    
' ---------------------------------------------------------
' start of at the designated array element
' ---------------------------------------------------------
  Do Until lStart > Hi
      '
      ' Look for a match in the array
'      If vData(lStart) = vSrchData Then
      If StrComp(vData(lStart), vSrchData, 0) = 0 Then
          '
          ' We found a match in the array
          IsInArray = True
          Exit Function
          '
      End If
      '
      ' increment the array index counter
      lStart = lStart + 1
        
  Loop
    
' ---------------------------------------------------------
' The search item could not be found in the array
' ---------------------------------------------------------
  IsInArray = False
    
End Function

Public Function RemoveDupes(vData As Variant)

' ---------------------------------------------------------
' Author:     Kenneth Ives      [e-mail]
'
' Syntax:     RemoveDupes TmpAray()
'
' Parameters:
'     vData - A variant pointing to an array to be parsed
'             for duplicate values assuming the data has
'             already been sorted by some other means
' ---------------------------------------------------------

' ---------------------------------------------------------
' Test to see if an array was passed
' ---------------------------------------------------------
  If Not IsArray(vData) Then Exit Function

' ---------------------------------------------------------
' Define variables
' ---------------------------------------------------------
  Dim lCurIndex As Long
  Dim lNextIndex As Long
  Dim lNewIndex As Long
  Dim i As Long
  Dim Hi As Long
  Dim vtemp As Variant

' ---------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------
  Hi = UBound(vData)   ' upper end of the array
  lNewIndex = 1
  i = 1
  ReDim tmpAray(1 To Hi) As String
    
' ---------------------------------------------------------
' Move the first valid value to the new array
' ---------------------------------------------------------
  Do
      If Len(vData(i)) <> 0 Then
          tmpAray(lNewIndex) = vData(i)
          Exit Do
      End If
      
      i = i + 1   ' Increment the counter
      
  Loop
  
' ---------------------------------------------------------
' Increment the counter so that we start comparing with
' the next value in the FOR NEXT loop
' ---------------------------------------------------------
  i = i + 1
    
' ---------------------------------------------------------
' Start the comparison process.  We will go thru every
' item in the array and look for duplicate values.
' ---------------------------------------------------------
  For lCurIndex = i To Hi
     
      ' increment the counter for the next
      ' item in the array and empty the
      ' temporary holding variable
      lNextIndex = lCurIndex + 1
      vtemp = ""
      
      ' if we have reached the end of the
      ' array then leave before we get a
      ' "Subscript out of range" error.
      If lNextIndex > Hi Then Exit For
          
      ' See if we already have it in the new
      ' array.  If yes, then empty the array item
      If vData(lCurIndex) = tmpAray(lNewIndex) Then
          vData(lCurIndex) = ""
      End If
      
      ' if the value is greater than an empty string,
      ' move the data to a temporary holding variable
      If Len(Trim(vData(lCurIndex))) > 0 Then
          vtemp = vData(lCurIndex)
          '
          ' See if the data is in the array starting
          ' from the next position and go to the end.
          ' If it is not in the array then add it
          ' to the new array and increment the count.
          ' We will pass the complete array, the data
          ' to look for, and the stating point in the
          ' array.
          If IsInArray(vData, vtemp, lNextIndex) Then
              vData(lCurIndex) = ""
          Else
              ' increment the index for the new array
              ' and add the item of data to it.
              lNewIndex = lNewIndex + 1
              tmpAray(lNewIndex) = vtemp
          End If
      End If
      '
  Next
   
' ---------------------------------------------------------
' Empty the passed array
' ---------------------------------------------------------
  ReDim vData(1 To Hi) As String
  
' ---------------------------------------------------------
' Transfer data from the temp(New) array back into
' the passed array
' ---------------------------------------------------------
  For lCurIndex = 1 To Hi
      vData(lCurIndex) = tmpAray(lCurIndex)
  Next
   
End Function