sorting an order of contract type

Hi Sean,

The attached file contains the following VBA Code. I had one problem, probably because I did not understand your requirements. I put down 'VM' twice where you have it only once.

The algorithm I used was:
Possible Solution Algorithm:
a. Create a list of items in a string: Site ID, Start Date (as yyyymmdd), Coded Priority, End Date (as yyyymmdd)
e.g. '1234 , 20140101, BBA , 20170301'
b. Sort the Strings
c. Put the Strings in the Output List (removing the first 2 characters) of the encoded value.
d. Put the Latest End Date for a 'Site Id' as 'Not Contracted'

Encode the Site Ids in Priority order as:
AAARC
BBA
CCB
DDVM
EENRG
FFNS
GGNot contracted

Option Explicit

Sub ClearDataAreaInSheetOutout()
  'This Clears the 'Output Sheet'

  Dim ws As Worksheet

  Set ws = Sheets("Outout")
  ws.Range("C2:Z" & Rows.Count).Clear

  'Clear objet pointers
  Set ws = Nothing

End Sub


Function EncodeContractId(sOriginalId As String) As String
  'This encodes 'Contract Ids' according to priority
  '
  'The contracts available are in order of priority:
  'Arc
  'A
  'B
  'VM but will be listed in the 2 sheets as either Peugeot or Citroen
  'NRG
  'NS
  'Not contracted
  
  
  Dim sLocalId As String
  Dim sEncodedValue As String
  
  'Create an UPPER case copy of the 'Original Id' (removed leading/trailing spaces)
  sLocalId = UCase(Trim(sOriginalId))
  
  Select Case sLocalId
  
    Case "ARC"
      sEncodedValue = "AA" & sOriginalId
  
    Case "A"
      sEncodedValue = "BB" & sOriginalId
  
    Case "B"
      sEncodedValue = "CC" & sOriginalId
  
    Case "PEUGEOT", "CITROEN"
      sEncodedValue = "DD" & "VM"
  
    Case "NRG"
      sEncodedValue = "EE" & sOriginalId
  
    Case "NS"
      sEncodedValue = "FF" & sOriginalId
  
    Case "Not Contracted"
      sEncodedValue = "GG" & sOriginalId
  
  End Select
  
  'Set the return value
  EncodeContractId = sEncodedValue

End Function


Sub SortContracts()
  'This sorts the Contracts and puts the Data in the 'Output Area'

  Dim ws As Worksheet
  Dim myEndDate As Date
  Dim myEndDateLatest As Date
  Dim myStartDate As Date

  Dim i As Long
  Dim iLastColumn As Long
  Dim iLastRow As Long
  Dim iMaxArrayItemCount As Long
  Dim iRow As Long
  
  Dim a() As String
  Dim sArray() As String
  Dim sConcatenation As String
  Dim sContractId As String
  Dim sEndDate As String
  Dim sSiteIdPrevious As String
  Dim sSiteId As String
  Dim sStartDate As String
  Dim sValue As String
  
  
  'Initialize the Array
  iMaxArrayItemCount = 0
  ReDim sArray(1 To 1)
  
  'Clear the Output Data Area
  Call ClearDataAreaInSheetOutout
  
  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Read and Encode the Data from Sheet 'Contract'
  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  
  'Create the Worksheet Object
  Set ws = Sheets("In Contract")
  
  'Find the Last Row on the Sheet
  iLastRow = ws.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

  'Put the Data in the Array
  For iRow = 2 To iLastRow
  
    'Read the Data
    sSiteId = Trim(ws.Cells(iRow, "B").Value)
    sContractId = Trim(ws.Cells(iRow, "C").Value)
    sStartDate = Trim(ws.Cells(iRow, "D").Value)
    sEndDate = Trim(ws.Cells(iRow, "E").Value)
  
    'Replace the 'Contract Id' with an encoded 'Contract Id'
    'Replace the 'Start Date' with an 'yyyymmdd' string
    sContractId = EncodeContractId(sContractId)
    sStartDate = Format(sStartDate, "yyyymmdd")
    sEndDate = Format(sEndDate, "yyyymmdd")
    
    'Create the composite string and put the value in the array
    sConcatenation = sSiteId & " , " & sStartDate & " , " & sContractId & " , " & sEndDate
    iMaxArrayItemCount = iMaxArrayItemCount + 1
    ReDim Preserve sArray(1 To iMaxArrayItemCount)
    sArray(iMaxArrayItemCount) = sConcatenation
  
  Next iRow
  
  
  
  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Read and Encode the Data from Sheet 'Terminated'
  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  Set ws = Sheets("Terminated")
  
  'Find the Last Row on the Sheet
  iLastRow = ws.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

  'Put the Data in the Array
  For iRow = 2 To iLastRow
  
    'Read the Data
    sSiteId = Trim(ws.Cells(iRow, "B").Value)
    sContractId = Trim(ws.Cells(iRow, "C").Value)
    sStartDate = Trim(ws.Cells(iRow, "D").Value)
    sEndDate = Trim(ws.Cells(iRow, "E").Value)
  
    'Replace the 'Contract Id' with an encoded 'Contract Id'
    'Replace the 'Start Date' with an 'yyyymmdd' string
    sContractId = EncodeContractId(sContractId)
    sStartDate = Format(sStartDate, "yyyymmdd")
    sEndDate = Format(sEndDate, "yyyymmdd")
    
    'Create the composite string and put the value in the array
    sConcatenation = sSiteId & " , " & sStartDate & " , " & sContractId & " , " & sEndDate
    iMaxArrayItemCount = iMaxArrayItemCount + 1
    ReDim Preserve sArray(1 To iMaxArrayItemCount)
    sArray(iMaxArrayItemCount) = sConcatenation
  
  Next iRow
    
  
  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Sort the Data
  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  Call LjmBubbleSortString(sArray)
  
  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Put the Data in Sheet 'Outout'
  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  Set ws = Sheets("Outout")

  For i = 1 To iMaxArrayItemCount
  
    'Get the Data
    'Parse the Data
    sValue = sArray(i)
    Call LjmParseString(sValue, a)
    
    'Get the values from the parsed string (remove leading/trailing spaces)
    sSiteId = Trim(a(0))
    sStartDate = Trim(a(1))
    sContractId = Trim(a(2))
    sEndDate = Trim(a(3))
    
    'Decode the 'Contract Id' and the 'Date'
    sContractId = Right(sContractId, Len(sContractId) - 2)
    myStartDate = yyyymmddToDate(sStartDate)
    myEndDate = yyyymmddToDate(sEndDate)
    
    'Debug.Print i, sSiteId, sContractId, myStartDate, myEndDate
    
    'Output 'Not Contracted' for the Latest 'End Date'
    If i > 1 And sSiteId <> sSiteIdPrevious Then
    
      ws.Cells(iRow, iLastColumn).Offset(0, 3).Value = myEndDateLatest
      ws.Cells(iRow, iLastColumn).Offset(0, 4).Value = "Not contracted"
    
      'Initialize the 'Latest' End Date for the next 'Site Id'
      myEndDateLatest = CDate("January 1, 2000")
    End If
    
    
    'Find the row in Colum 'B' that contains the 'Site Id' in Column 'B'
    'Find the 'Last Column' used in the row
    iRow = ws.Range("B:B").Find(What:=sSiteId, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    iLastColumn = ws.Rows(iRow).Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

    'Put the data in the SpreadSheet
    ws.Cells(iRow, iLastColumn).Offset(0, 1).Value = myStartDate
    ws.Cells(iRow, iLastColumn).Offset(0, 2).Value = sContractId
    
    'Save the 'Latest' End Date for this 'Site Id'
    If myEndDate > myEndDateLatest Then
      myEndDateLatest = myEndDate
    End If
    
    'Save the 'Site Id'
    sSiteIdPrevious = sSiteId
    
  Next i

  'Output the 'Last' 'Not Contracted'
  ws.Cells(iRow, iLastColumn).Offset(0, 3).Value = myEndDateLatest
  ws.Cells(iRow, iLastColumn).Offset(0, 4).Value = "Not contracted"


  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Termination
  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  
  'Clear object pointers
  Set ws = Nothing

End Sub


Sub LjmBubbleSortString(ByRef myArray() As String)
  'This sorts a string array in ascending order using a 'Bubble Sort' algorithm
     
  Dim iFirst As Long
  Dim iLast As Long
  Dim i As Long
  Dim j As Long
  Dim sTemp As String
     
  'Get the start and end indices
  iFirst = LBound(myArray)
  iLast = UBound(myArray)
    
  'Sort
  For i = iFirst To iLast - 1
    For j = i + 1 To iLast
      If myArray(i) > myArray(j) Then
        sTemp = myArray(j)
        myArray(j) = myArray(i)
        myArray(i) = sTemp
      End If
   Next j
 Next i
     
End Sub

Function LjmParseString(InputString As String, ByRef sArray() As String) As Long
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' This parses a comma delimited string into an array of tokens.
' Leading and trailing spaces are stripped from the string in the process.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  Dim i As Integer
  Dim LastNonEmpty As Integer
  Dim iSplitIndex As Integer

 'Initialization
  LastNonEmpty = -1
  
  'Split the string into tokens
  sArray = Split(InputString, ",")
  iSplitIndex = UBound(sArray)

 'Remove the null tokens
  For i = 0 To iSplitIndex

    If sArray(i) <> "" Then
       'Get rid of all the whitespace
        LastNonEmpty = LastNonEmpty + 1
        sArray(LastNonEmpty) = sArray(i)
    End If
  Next i


 'Return the number of indices
  LjmParseString = LastNonEmpty
  
End Function

Function yyyymmddToDate(syyyymmdd As String) As Date
  'This converts a date string of the form 'yyyymmdd' to an Excel Date
  '
  'NOTE: The year must be 1904 >= year <= 2037

  Dim myDate As Date
  
  Dim iYear As Long
  
  Dim sYear As String
  Dim sMonth As String
  Dim sDayOfMonth As String
  
  If Len(syyyymmdd) = 8 And IsNumeric(syyyymmdd) Then
    sYear = Mid(syyyymmdd, 1, 4)
    sMonth = Mid(syyyymmdd, 5, 2)
    sDayOfMonth = Mid(syyyymmdd, 7, 2)
    
    iYear = CInt(sYear)
    If iYear >= 1904 And iYear <= 2037 Then
      myDate = DateSerial(iYear, CInt(sMonth), CInt(sDayOfMonth))
    End If
    
  End If

  'Set the return value
  yyyymmddToDate = myDate

End Function

Lewis

Hi Sean,

It's good to see you active again. I was going to suggest the fix you posted if couldn't fix it yourself. I figured I had to let you have a little fun.

Lewis