RE: Checking if entry is already in List

Tech-Archive recommends: Repair Windows Errors & Optimize Windows Performance

Below is an InsertItem subroutine, a fast Heap sort, and a binary search to
go with it. I think I included everything. If you don't like my use of
global constants "Yes" and "No" you will need to replace them with True and
False.

If you build your list from scratch using InsertItem it will be sorted and
the heap sort is not required. You will only need to use the heap sort
before inserting an item for the first time into an otherwise unsorted list.
It will remain sorted thereafter.

P.S. This implementation of the heap sort (using GoTo's) is faster than
other implementations of the same sort method I have found.


Global Const Yes As Boolean = True
Global Const No As Boolean = False
'
Public Sub InsertItem(txt() As String, NewItem As String, Optional ipos As
Long, _
Optional DupsAllowed As Boolean = Yes)
'
' inserts a new item at the requested position (if supplied) or at its
appropriate
' position ascending (if not supplied)
'
Dim ExactMatch As Boolean
Dim nent As Long
Dim i As Long
'
' check for an empty array and insert the item at the requested position
or position 1
'
nent = UBnd(txt)
If nent = 0 Then
nent = Max0(ipos, 1)
ReDim txt(nent)
txt(nent) = NewItem
Exit Sub
End If
'
' if inserting an item at a specific location then dups are automatically
allowed
'
If ipos > 0 Then
ReDim Preserve txt(Max0(ipos, nent + 1))
For i = UBound(txt) To ipos + 1 Step -1
txt(i) = txt(i - 1)
Next i
txt(ipos) = NewItem
Exit Sub
End If
'
' find the insertion position but skip insertion if no dups allowed and
the item is
' already in the list
'
ExactMatch = No
BinSearch txt, NewItem, ExactMatch, ipos
If Not ExactMatch Or DupsAllowed Then
ReDim Preserve txt(nent + 1)
For i = UBound(txt) To ipos + 1 Step -1
txt(i) = txt(i - 1)
Next i
txt(ipos) = NewItem
End If
'
End Sub
Public Sub BinSearch(txt() As String, find As String, ExactMatch As Boolean,
ipos As Long)
'
' performs a binary search of a sorted string array for a particular item
'
' if a match is found
' BinSearch returns the position of a single matching item or returns
' the first occurrence of multiple matching items
' and returns ExactMatch = Yes
'
' if no match is found
' if ExactMatch = Yes, BinSearch returns ExactMatch = No and ipos = 0
' if ExactMatch = No, BinSearch returns ExactMatch = No and either
' 1) ipos = the position of the first item greater than the
desired item, or
' 2) ipos = the array length plus one (LenArray + 1) if no items
greater
' (i.e. ipos returns the appropriate insertion position for this
item)
'
' the array must be sorted ascending
'
Dim nent As Long
Dim lpos As Long
Dim mpos As Long
'
' check for an empty list
'
nent = UBnd(txt)
If nent <= 0 Then
If ExactMatch Then
ExactMatch = No
ipos = 0
Else
ipos = 1
End If
Exit Sub
End If
'
' one entry - check for a match
'
If nent = 1 Then
If find = txt(1) Then
ExactMatch = Yes
ipos = 1
Else
If ExactMatch Then
ExactMatch = No
ipos = 0
Else
If find < txt(1) Then
ipos = 1
Else
ipos = 2
End If
End If
End If
Exit Sub
End If
'
' set up for a binary search
'
ipos = 1
lpos = nent
'
' calculate the midpoint of the list (NOTE - use the integer division
operator!)
'
Do
mpos = ipos + (lpos - ipos) \ 2
'
' only two items left to check when the middle position is equal to the
lowest position
' 1) first check the two items for an exact match and exit if found
' 2) if an exact match is required then flag "no match" and exit
' 3) otherwise flag "no match" and find the correct insertion position
'
If mpos = ipos Then
For ipos = mpos To mpos + 1
If find = txt(ipos) Then
ExactMatch = Yes
Exit Sub
End If
Next ipos
If ExactMatch Then
ExactMatch = No
ipos = 0
Exit Sub
End If
ExactMatch = No
For ipos = mpos To mpos + 1
If find < txt(ipos) Then Exit Sub
Next ipos
Exit Sub
End If
'
' if exact match found then move back to the first matching item if possible
'
If find = txt(mpos) Then
Do While mpos > 1 And txt(mpos - 1) = find
mpos = mpos - 1
Loop
ExactMatch = Yes
ipos = mpos
Exit Sub
End If
'
' choose the remaining half of the list
'
If find > txt(mpos) Then
ipos = mpos
Else
lpos = mpos
End If
'
Loop
'
End Sub
Public Sub StrSort(txt() As String)
'
' fast "Heap" sort alogrithm from Knuth - The Art of Computer Programming
'
Dim i As Long
Dim j As Long
Dim nent As Long
Dim ist As Long
Dim lst As Long
Dim Tmp As String
'
' need at least two entries in the array to do a sort
'
nent = UBnd(txt)
If nent < 2 Then Exit Sub
'
' set sort pointers to the midpoint and endpoint of the array (NOTE - use
the
' integer division operator!)
'
ist = nent \ 2 + 1
lst = nent
'
' do an ascending sort
'
110:
If ist > 1 Then
ist = ist - 1
Tmp = txt(ist)
Else
Tmp = txt(lst)
txt(lst) = txt(1)
lst = lst - 1
If lst = 1 Then
txt(lst) = Tmp
Exit Sub
End If
End If
'
j = ist
'
120:
i = j
j = j * 2
'
If j = lst Then
If Tmp >= txt(j) Then
txt(i) = Tmp
GoTo 110
End If
txt(i) = txt(j)
GoTo 120
End If
'
If j > lst Then
txt(i) = Tmp
GoTo 110
End If
'
If txt(j) < txt(j + 1) Then j = j + 1
If Tmp >= txt(j) Then
txt(i) = Tmp
GoTo 110
End If
'
txt(i) = txt(j)
GoTo 120
'
End Sub
Public Function Max0(num1 As Long, num2 As Long) As Long
'
' returns the largest of two long numbers
'
If num1 > num2 Then
Max0 = num1
Else
Max0 = num2
End If
'
End Function
Public Function UBnd(Arg1 As Variant, Optional iDim As Long = 1) As Long
'
' returns zero if array is undefined
'
On Error Resume Next
If IsArray(Arg1) Then UBnd = UBound(Arg1, iDim)
'
End Function


.

Relevant Pages

  • 2 Dim Array Sort, on any columns, ascend or descend. Guidance des
    ... descending for each column to be part of the sort. ... is that a sort key is built, an array of keys is sorted, and then used to ... Dim WarnErrMsg As String ...
    (microsoft.public.excel.programming)
  • Re: Make Table Query - Sorting Errors
    ... Dim OutputTable As DAO.Recordset ... The query to concatenate the CAMPNO values will need to be LOOKING at the ... If you post the query you are using to do this, I beleive we can get it to ... Is there a command that I can use in the module code to first sort the ...
    (microsoft.public.access.queries)
  • Re: VBA Sort 2-dimensional array based on 2 column
    ... I pull all of the data into an array then I ... Some of the fields are blank, can that mess up the sort? ... Dim i As Long, j As Long ... 'MergeSort recursively calls itself until we have lists short enough ...
    (microsoft.public.office.developer.vba)
  • Re: VBA Sort 2-dimensional array based on 2 column
    ... a simple bubble sort should work fine. ... If your array is named myArray, and you want to sort by column 5 (say age ... Dim i As Long, j As Long ... Dim ColNr As Long ...
    (microsoft.public.office.developer.vba)
  • Re: VBA Sort 2-dimensional array based on 2 column
    ... Maybe you could transpose the List, sort, transpose again, and stick it back ... Dim conlist as Variant ... Function Transpose(vOld As Variant) As Variant ... 'MergeSort recursively calls itself until we have lists short ...
    (microsoft.public.office.developer.vba)