alphabetizing a list of names by last name

well, you need to provide us a little more information. Where are these 7000 names stored? Database? Flat file? The answer to these questions will determine the answer to your own.

If its a database, are the first, middle, and last names in their own respective fields or in one field? If its a flat file, are these entries tab delimited or just strung together in one big long string?

Gotta know the data structure to answer your question.


Ed.

They are in a random data file with the each name being in 1string (No first/middle/last) so I would have to loop thru the entire database file and read each name and then do what I need to do.

Is this correct?
1 Anna Maria/Middle/Surname
2 John//Tucker

Are you using VB6?

assuming you know how to read the file then its a simple of matter of arranging them in an array structure as you read them.

as you read each last name from the file, compare it against those you've already read and insert it into the array in its alphabetized slot.

or, even easier than that. read this random file into an ordinary text file. now, import it into ms access. in the import, set the "column" where each field begins/ends. now, once the data is there you can sort it on any field you desire.

comparing the two methods of reaching your goal, i'd say the latter is the way to go. dump it into access and then do what you want with it. you'll be done with it in an hour as opposed to 3 or four the former way.

ed.

Ok, here you go...

On a form, stick a text box, a command button and a list box.

Then paste the code from the following code module.

As you can see, you can enter the names in the text box, and every time you hit enter it puts it in the correct place in the list.

It is very easy to modify this code to do exactly what you want.

Good luck!

Pino

Ok, here you go...

On a form, stick a text box, a command button and a list box.

Then paste the code from the following code module.

As you can see, you can enter the names in the text box, and every time you hit enter it puts it in the correct place in the list.

It is very easy to modify this code to do exactly what you want.

Good luck!

Pino

Option Explicit
Dim objCollection As Collection

Private Sub Command1_Click()

Dim lngIndex As Long
Dim blnMatch As Boolean

BinarySearch Text1.Text, lngIndex, blnMatch

If lngIndex = 0 Then
    If objCollection.Count = 0 Then
        objCollection.Add Text1.Text
    Else
        objCollection.Add Text1.Text, , 1
    End If
Else
    objCollection.Add Text1.Text, , , lngIndex
End If

List1.Clear
For lngIndex = 1 To objCollection.Count
    List1.AddItem objCollection(lngIndex)
Next

Text1.SelStart = 0
Text1.SelLength = Len(Text1.Text)

End Sub

Private Sub BinarySearch(ByVal strString As String, lngIndex As Long, blnMatch As Boolean)

If objCollection Is Nothing Then
    Set objCollection = New Collection
    lngIndex = 0
    blnMatch = False
    Exit Sub
End If

If GetLastName(objCollection(1)) > GetLastName(strString) Then
    lngIndex = 0
    blnMatch = False
    Exit Sub
End If

If GetLastName(objCollection(objCollection.Count)) <= GetLastName(strString) Then
    lngIndex = objCollection.Count
    blnMatch = False
    Exit Sub
End If

Dim lngStart As Long
Dim lngEnd As Long
Dim lngCurrent As Long

lngStart = 1
lngEnd = objCollection.Count
lngCurrent = (lngEnd + lngStart) \ 2
Do While lngStart < lngEnd - 1
    If GetLastName(objCollection(lngCurrent)) <= GetLastName(strString) Then
        lngStart = lngCurrent
    Else
        lngEnd = lngCurrent
    End If
    lngCurrent = (lngEnd + lngStart) \ 2
Loop

lngIndex = lngCurrent

End Sub

Private Function GetLastName(ByVal strString As String) As String

Dim intPos As Integer
Dim intLastPos As Integer

intPos = InStr(strString, " ")

If intPos = 0 Then
    GetLastName = UCase(strString)
    Exit Function
End If

Do While intPos > 0
    intLastPos = intPos
    intPos = InStr(intPos + 1, strString, " ")
Loop

GetLastName = UCase(Right(strString, Len(strString) - intLastPos)) & ", " & Left(strString, intLastPos - 1)

End Function

(PS this should work fine in VB4)

caref_g should get the points.

Use GetTickCount, and tell us time to sort 7000 surnames.

Anyway... if you were working for me and I found you using collection for this ... I would suggest you - use array

Get the Most Out of Your Arrays
You can sort one hundred thousand items in one second, if you use the right algorithm

Since I'm a so nice I'll post you my sort routine it's kinda of fast, at least I think so. It uses a non-recursive Quicksort algorithm optimized for speed in VB using a temporary Long Array (speeds up when I use it for xxxxxx items =)).

I haven't benchmarked it much so if any feels like it plz post me the result.


Sub QuickSort(ByRef X() As String)

  On Error GoTo ErrorHandler
 
  Dim Pos() As Long
  Dim Temp As Long
  Dim iLeft() As Long
  Dim iRight() As Long
  Dim i As Long
  Dim j As Long
  Dim sp As Long
  Dim Mid As Long
  Dim MidStr As String
  Dim Y() As String
  Dim Pivot As String
  Dim a As Long
  Dim xPosi As String
 
  ReDim Y(UBound(X))
  ReDim Pos(UBound(X))
  ReDim iLeft(UBound(X))
  ReDim iRight(UBound(X))
 
  For a = 1 To UBound(X)
    Pos(a) = a
    Y(a) = X(a)
    X(a) = LCase$(X(a))
  Next
 
  iLeft(1) = 1
  iRight(1) = UBound(X)
  sp = 1
 
  Do While (sp > 0)
    DoEvents
    If iLeft(sp) >= iRight(sp) Then
      sp = sp - 1
    Else
      i = iLeft(sp)
      j = iRight(sp)
      Pivot = X(Pos(j))
      Mid = (i + j) \ 2
      If (j - i) > 5 Then
        MidStr = X(Pos(Mid))
        xPosi = X(Pos(i))
        If (MidStr < Pivot) Then
          If (MidStr > xPosi) Then
            Temp = Pos(Mid)
            Pos(Mid) = Pos(j)
            Pos(j) = Temp
          ElseIf (xPosi < Pivot) And ((xPosi > MidStr)) Then
            Temp = Pos(i)
            Pos(i) = Pos(j)
            Pos(j) = Temp
          End If
        ElseIf (MidStr > Pivot) Then
          If (MidStr < xPosi) Then
            Temp = Pos(Mid)
            Pos(Mid) = Pos(j)
            Pos(j) = Temp
          ElseIf (xPosi > Pivot) And ((xPosi < MidStr)) Then
            Temp = Pos(Mid)
            Pos(Mid) = Pos(j)
            Pos(j) = Temp
          End If
        End If
      End If
      Pivot = X(Pos(j))
 
      Do While (i < j)
        Do While (X(Pos(i)) < Pivot)
          i = i + 1
        Loop
        j = j - 1
        Do While (i < j) And (Pivot < X(Pos(j)))
          j = j - 1
        Loop
        If (i < j) Then
          Temp = Pos(i)
          Pos(i) = Pos(j)
          Pos(j) = Temp
        End If
      Loop
   
      j = iRight(sp)
      Temp = Pos(i)
      Pos(i) = Pos(j)
      Pos(j) = Temp
     
      If i - iLeft(sp) >= iRight(sp) - i Then
        iLeft(sp + 1) = iLeft(sp)
        iRight(sp + 1) = i - 1
        iLeft(sp) = i + 1
      Else
        iLeft(sp + 1) = i + 1
        iRight(sp + 1) = iRight(sp)
        iRight(sp) = i - 1
      End If
      sp = sp + 1
    End If
  Loop

  For a = 1 To UBound(X)
    X(a) = Y(Pos(a))
  Next
 
ErrorHandler:

End Sub

caraf_g gets the points

This is to caraf_g: Using this code,    Private Function GetLastName(ByVal strString As String) As String

      Dim intPos As Integer
      Dim intLastPos As Integer

      intPos = InStr(strString, " ")

      If intPos = 0 Then
          GetLastName = UCase(strString)
          Exit Function
      End If

      Do While intPos > 0
          intLastPos = intPos
          intPos = InStr(intPos + 1, strString, " ")
      Loop

      GetLastName = UCase(Right(strString, Len(strString) - intLastPos)) & ", " & Left(strString,
      intLastPos - 1)

      End Function


I would like to count how many peoples last names are between a-l and m-z, but I don't know where to set the counters in this routine. Or is it in the BinarySearch(ByVal strString As String, lngIndex As Long, blnMatch As Boolean)
routine?

Adjusted points to 250

This is for caraf_g...
The code you have supplied so far was great... Now I have sorted to the listbox all my names into alphabetical order and now I want to make two random access datafiles out of the the first one a_thru_l.dat and last one m_thru_z.dat
I am using this code:

z = 1
recnum = 1
    For z = 1 To al% Step 1      ;number of records a thru l
    For recnum = 1 To lastrecord
  List1.ListIndex = 0
  List1.Selected(0) = True
 applicant$ = List1.Text ;getting the first applicants name
  Get #2, recnum, primequote; getting record from main database
If applicant$ = Trim(primequote.applicant) Then ; comparing the two and if it's the same then
 Put #1, currentrecord, primequote ;put into a_thru_l.dat
   List1.RemoveItem (0); remove from listbox
  Exit For;exit from looking for this record
  End If
  recnum = recnum + 1; go onto next record to see if it's the applicant
  Next recnum
 
  Next z;next name in listbox
This code dosn't seem to be working properly,
what am I doing wrong?
I will add more points for you when this question is answered.

Can you tell me what your structure "primequote" looks like?

Sorry - I mean, can you give me your Type definition for "primequote"?

Here is the Type definition of primequote:
Type primequoteinfo
    leadrecieved As String * 15
    agent As String * 30
    applicant As String * 30
    ssn As String * 15
    dob As String * 15
    address As String * 50
    city As String * 20
    state As String * 10
    zip As String * 10
    homephone As String * 20
    workphone As String * 20
    ext As String * 6
    besttime As String * 500
    notes As String * 500
    datecontacted As String * 15
    datesent As String * 15
    dateexam As String * 15
    dateappmedical As String * 15
    dateappsent As String * 15
    datepolicyreceived As String * 15
    insurance As String * 50
    policytype As String * 50
    deathbenefit As String * 20
    smoker As Integer
    rated As Integer
    nonsmoker As Integer
    notrated As Integer
    preset As String * 1000
    presetvalue As Integer
    premium As Currency
    premmode As String * 15
    commission As Currency
    paid1 As String * 15
    paid2 As String * 15
    paid3 As String * 15
    paid4 As String * 15
    paid5 As String * 15
    paid6 As String * 15
    paid7 As String * 15
    paid8 As String * 15
    paid9 As String * 15
    paid10 As String * 15
    paid11 As String * 15
    paid12 As String * 15
    sex As String * 10
    predate As String * 10
    arrncp As String * 50
 End Type

And I open up both files with:
Close
    sortrecordlen = Len(primequote)
    sortfilenum = 1
    Open "a_thru_l.pqd" For Random As sortfilenum Len = sortrecordlen
    recordlen = Len(primequote)
   
    filenum = 2
    Open chosenfile$ For Random As filenum Len = recordlen
    currentrecord = 1
    lastrecord = FileLen(chosenfile) / recordlen
        If lastrecord = 0 Then
        lastrecord = 1
    End If
Whenever I run the above sort program (that I added today to this question)
The first record gets put in the new database but thats all.

OK, I've looked at the problem, and come up with a solution.

Again, I've based it on my original example, so you'll have to translate this into your example, but it shouldn't be too hard.

The trick is to use a class module, and a little bit of "object oriented" programming.

You can use the same form as with my first example. Also, add a class module into your project.

In the class module, paste the following:

Option Explicit
Public strLastName As String
Public strMiddle As String
Public strFirstName As String
Public strFullName As String

In the form module, paste the following, replacing all the existing code with new code:

Option Explicit
Dim objCollection As Collection
Private Type PrimeQuote
    strFirstName As String
    strMiddle As String
    strLastName As String
End Type
Private Sub Command1_Click()

Dim lngIndex As Long
Dim blnMatch As Boolean

Dim objPQ As clsPrimeQuote
Set objPQ = New clsPrimeQuote
objPQ.strFirstName = GetUnformattedFirstName(Text1.Text)
objPQ.strMiddle = GetUnformattedRemainder(Text1.Text)
objPQ.strLastName = GetUnformattedLastName(Text1.Text)
objPQ.strFullName = Text1.Text

BinarySearch objPQ, lngIndex, blnMatch

If lngIndex = 0 Then
    If objCollection.Count = 0 Then
        objCollection.Add objPQ
    Else
        objCollection.Add objPQ, , 1
    End If
Else
    objCollection.Add objPQ, , , lngIndex
End If

List1.Clear
For lngIndex = 1 To objCollection.Count
    Set objPQ = objCollection(lngIndex)
    List1.AddItem objPQ.strFullName
Next

Text1.SelStart = 0
Text1.SelLength = Len(Text1.Text)

End Sub

Private Sub BinarySearch(objPQ As clsPrimeQuote, lngIndex As Long, blnMatch As Boolean)

If objCollection Is Nothing Then
    Set objCollection = New Collection
    lngIndex = 0
    blnMatch = False
    Exit Sub
End If

Dim objCPQ As clsPrimeQuote

Set objCPQ = objCollection(1)
If UCase(objCPQ.strLastName & ", " & objCPQ.strFirstName & " " & objCPQ.strMiddle) > _
   UCase(objPQ.strLastName & ", " & objPQ.strFirstName & " " & objPQ.strMiddle) Then
    lngIndex = 0
    blnMatch = False
    Exit Sub
End If

Set objCPQ = objCollection(objCollection.Count)
If UCase(objCPQ.strLastName & ", " & objCPQ.strFirstName & " " & objCPQ.strMiddle) <= _
   UCase(objPQ.strLastName & ", " & objPQ.strFirstName & " " & objPQ.strMiddle) Then
    lngIndex = objCollection.Count
    blnMatch = False
    Exit Sub
End If

Dim lngStart As Long
Dim lngEnd As Long
Dim lngCurrent As Long

lngStart = 1
lngEnd = objCollection.Count
lngCurrent = (lngEnd + lngStart) \ 2
Do While lngStart < lngEnd - 1
    Set objCPQ = objCollection(lngCurrent)
    If UCase(objCPQ.strLastName & ", " & objCPQ.strFirstName & " " & objCPQ.strMiddle) <= _
       UCase(objPQ.strLastName & ", " & objPQ.strFirstName & " " & objPQ.strMiddle) Then
        lngStart = lngCurrent
    Else
        lngEnd = lngCurrent
    End If
    lngCurrent = (lngEnd + lngStart) \ 2
Loop

lngIndex = lngCurrent

End Sub


Private Function GetUnformattedLastName(ByVal strString As String) As String

Dim intPos As Integer
Dim intLastPos As Integer

intPos = InStr(strString, " ")

If intPos = 0 Then
    GetUnformattedLastName = strString
    Exit Function
End If

Do While intPos > 0
    intLastPos = intPos
    intPos = InStr(intPos + 1, strString, " ")
Loop

GetUnformattedLastName = Right(strString, Len(strString) - intLastPos)

End Function
Private Function GetUnformattedFirstName(ByVal strString As String) As String

Dim intPos As Integer

intPos = InStr(strString, " ")

If intPos = 0 Then
    GetUnformattedFirstName = ""
    Exit Function
End If

GetUnformattedFirstName = Left(strString, intPos - 1)

End Function
Private Function GetUnformattedRemainder(ByVal strString As String) As String

Dim intPos As Integer
Dim intLastPos As Integer
Dim intFirstPos As Integer

intPos = InStr(strString, " ")

If intPos = 0 Then
    GetUnformattedRemainder = ""
    Exit Function
End If

intFirstPos = intPos
Do While intPos > 0
    intLastPos = intPos
    intPos = InStr(intPos + 1, strString, " ")
Loop

If intFirstPos = intLastPos Then
    GetUnformattedRemainder = ""
    Exit Function
End If

GetUnformattedRemainder = Mid(strString, intFirstPos + 1, intLastPos - intFirstPos - 1)

End Function

When you modify this to work with your code, your class module will look a lot like your PrimeQuote type. In actual fact you can interpret the clsPrimeQuote Class as an "object" interpretation of the Type PrimeQuote. In that sense, classes and types are very similar things.

But as you can see from my code, you can do wonderful things with class types, in conjunction with using a collection. That's where the real strength of this programming comes in.

Now to fixing your problem of writing the data files...

I would write something like the following. Remember, we've got a collection that contains all the entries, nicely sorted, and handily wrapped up in clsPrimeQuote objects...

'Declare an object of type clsPrimeQuote
Dim objPQ As clsPrimeQuote
'Declare a user-type variable of type PrimeQuote
Dim udtPQ As PrimeQuote

'blank out file before we start
Dim intFile As Integer
intFile = FreeFile
Open "yourFile" for Output As #intFile
Close #intFile

'Then open it for writing to:
intFile = FreeFile
Open "yourFile" For Random As #intFile Len = Len(udtPQ)

For z = 1 To al% Step 1      ;number of records a thru l
    Set objPQ = objCollection(z)
    'Now, transfer all the data to the udt variable:
    udtPQ.strFirstName = objPQ.strFirstName
    udtPQ.strMiddle = objPQ.strMiddle
    udtPQ.strLastName = objPQ.strLastName
    'Once you've done this, it is in a handy format to _
     write to your file. So you don't need to access the _
     original file again (as in your code).
    Put #intFile, ,udtPQ
Next z
Close #intFile

'Note that for correct results you must define the elements of PrimeQuote as fixed strings - but I see you've done this so you're OK.

Hope this helps!

Good luck

Pino

To caraf_g,
Help... with the above code I get the error, User Defined Type not defined error with the lines:
Dim objPQ As clsPrimeQuote
Dim udtPQ As primequote
and the routine:
Private Sub binarysrch(objPQ As clsPrimeQuote, lngIndex As Long, blnMatch As Boolean)
What do I need to change to fix this...

Hi dtucker,

Start with my comment of
Wednesday, July 14 1999 - 03:04PM PDT  

So
1 - create a class module, and paste in the code (4 lines)
    You'll need to go into the properties for the class module, and make sure it's called clsPrimeQuote
2 - paste the code from
Date: Wednesday, July 14 1999 - 03:05PM PDT  into the form module, replacing existing code.

3 - now if you use the code of
Wednesday, July 14 1999 - 03:19PM PDT
it should no longer come up with those errors.

Good luck

Pino

To caraf_g,
I am still having a problem with the line:
Dim udtPQ As PrimeQuote
Giving me the same error, I think it's because I use primequote as another variable, as everytime I try to capitalize the P and Q they convert to small case.
When I change the line to read:
Dim udtPQ As udt PrimeQuote
The case dosn't change but I still get the same error.
I couldn't paste the code in yet to replace mine because I did alot of changing to get it to do things that I needed, I simpley added the different routines that were different and changed BinarySearch routine to BnrySearch and fixed the line calling it in order to keep both the routines. And once I get you new routine running and doing what I need it to do then I will weed out what's not needed.

Ah, I see. Ok, I'm talking about my example, but you're already implementing it in your program. That's fine, but just be aware that I've defined a type named
PrimeQuote in my example.

Your best bet is to change the type declaration
in my example I declared it as
Private Type PrimeQuote
    strFirstName As String
    strMiddle As String
    strLastName As String
End Type

In your case it will be a lot longer. But I would do
Private Type dtuckerPrimeQuote 'for example
    strFirstName As String
    strMiddle As String
    strLastName As String
End Type

And everywhere where in my code I did something like
Dim udtPQ As PrimeQuote
replace that with
Dim udtPQ As dtuckerPrimeQuote

And that should get you around that problem.

Good luck

Pino