ANStrList functions

Set of functions to manage ANStrList strings, read, save, delete, sort, compare, count and create unique
ANStrList is one string having multiple items separated by known separator
Functions:
List_ItemRead: To read item from list by its ID
List_ItemSave: Returns list after modifying certain item by its ID
List_ItemsModify: Returns list of items after adding or deleting items, preserving list uniqueness.
List_ItemsCount: returns count of items in list
List_ItemsSort: To sort list items in list alphabetically, using ADOR.Recordset object
List_ItemSearch: searching for an item in list
List_ItemsUnique: Returns list of unique items in list
List_Compare: Compares between two ANStrlists, returns 1 if match, 0 if not, with option to compare order too or not


Public

Tested

My Own Work
Function List_ItemRead(ANStrList, Optional ItemID = 1, Optional Sepa = "|")
   List_ItemRead = CutString3(ANStrList, ItemID, Sepa)
End Function

Function List_ItemSave(ANStrList, Optional ItemID = 1, Optional NewItem = "Item text", Optional Sepa = "|")
   Rett = ""
   X1 = 0
   For Each Item1 In Split(ANStrList, Sepa)
      X1 = X1 + 1
      Item2 = Item1
      If X1 = ItemID Then Item2 = NewItem
      If Rett > "" Then Rett = Rett & Sepa
      Rett = Rett & NewItem
   Next
   If Rett > "" Then List_ItemSave = Rett
End Function

Function List_ItemsModify(ANStrList, _
   Optional Items2Del = "Strings|seperated|by|Sepa", _
   Optional Items2Add = "Strings|seperated|by|Sepa", _
   Optional Sepa = "|")
   
   ' Preserves uniqueness of list
   List_ItemsModify = ANStrList
   If Items2Del = "Strings|seperated|by|Sepa" And Items2Add = "Strings|seperated|by|Sepa" Then Exit Function
   If Items2Del = "Strings|seperated|by|Sepa" Then Items2Del = ""
   If Items2Add = "Strings|seperated|by|Sepa" Then Items2Add = ""
   Dim NL, NLAdd, NLDel
   NL = ""
   ' Delete items
   For Each Item1 In Split(ANStrList, Sepa)
      Item1 = Trim(Item1)
      If Item1 = "" Then GoTo Next1
      Found1 = 0
      For Each Item2 In Split(Items2Del, Sepa)
         Item2 = Trim(Item2)
         If Item2 = "" Then GoTo Next2
         If UCase(Item1) = UCase(Item2) Then
            Found1 = 1
            Item4 = ""
            Exit For
         End If
Next2:
      Next
      If Found1 = 0 Then Item4 = Item1
Next1:
      If Item4 > "" Then
         If NL > "" Then NL = NL & Sepa
         NL = NL & Item4
      End If
   Next
   If NL > "" Then ANStrList = NL
   ' Add Items only if not found
   For Each Item3 In Split(Items2Add, Sepa)
      Item3 = Trim(Item3)
      If Item3 = "" Then GoTo Next3
      Found1 = 0
      For Each Item1 In Split(ANStrList, Sepa)
         Item1 = Trim(Item1)
         If Item1 = "" Then GoTo Next4
         If UCase(Item1) = UCase(Item3) Then
            Found1 = 1
            Exit For
         End If
Next4:
      Next
      If Found1 = 0 Then
         If NL > "" Then NL = NL & Sepa
         NL = NL & Item3
      End If
Next3:
   Next
   List_ItemsModify = NL
End Function

Function List_ItemSearch(ANStrList, SearchFor, Optional Sepa = "|")
   ' Searches for an item in an ANStrList list
   '  Returns id of item or 0 if not found
   ' Needs CutString3
   Return1 = 0
   ItemID = 1
   Do
      Cut3 = CutString3(ANStrList, ItemID, Sepa)
      If UCase(Trim(SearchFor)) = UCase(Trim(Cut3)) Then Return1 = 1
      If Cut3 = "" Or Cut3 = ANStrList Then Exit Do
      If IsNumeric(SearchFor) Then
         If Val(SearchFor) = Val(Cut3) Then
            Return1 = ItemID
            Exit Do
         End If
      Else
         If UCase(Trim(SearchFor)) = UCase(Trim(Cut3)) Then
            Return1 = ItemID
            Exit Do
         End If
      End If
      ItemID = ItemID + 1
   Loop
   List_ItemSearch = Return1
End Function

Function List_ItemsSort(ANStrList, Optional Sepa = "|")
   Const adVarChar = 200
   Const MaxCharacters = 255
   Rett = ANStrList
   Set DataList = CreateObject("ADOR.Recordset")
   DataList.Fields.Append "Column1", adVarChar, MaxCharacters
   DataList.Open
   For Each Itt In Split(Rett, Sepa)
      DataList.AddNew
      DataList("Column1") = Itt
      DataList.Update
   Next
   DataList.Sort = "Column1"
   DataList.MoveFirst
   Rett = ""
   Do Until DataList.EOF
      If Rett > "" Then Rett = Rett & Sepa
      Rett = Rett & DataList.Fields.Item("Column1")
      DataList.MoveNext
   Loop
   List_ItemsSort = Rett
End Function

Function List_ItemsCount(ANStrList, Optional Sepa = "|", Optional CountUnique = 1)
    CoAN = 0
    CoANUni = 0
    UniList = ""
    For Each Item1 In Split(ANStrList, Sepa)
        Item1 = Trim(Item1)
        If Item1 = "" Then GoTo Next1
        CoAN = CoAN + 1
        Found1 = 0
        For Each Item2 In Split(UniList, Sepa)
            Item2 = Trim(Item2)
            If Item2 = "" Then GoTo Next2
            If UCase(Item1) = UCase(Item2) Then
                Found1 = 1
                Exit For
            End If
Next2:
        Next
        If Found1 = 0 Then
            CoANUni = CoANUni + 1
            If UniList > "" Then UniList = UniList & Sepa
            UniList = UniList & Item1
        End If
Next1:
    Next
    List_ItemsCount = CoAN
    If CountUnique = 1 Then List_ItemsCount = CoANUni
End Function

Function List_ItemsUnique(ANStrList, Optional Sepa = "|")
    ' Gets list of unique items
    UniList = ""
    For Each Item1 In Split(ANStrList, Sepa)
        Item1 = Trim(Item1)
        If Item1 = "" Then GoTo Next1
        Found1 = 0
        For Each Item2 In Split(UniList, Sepa)
            Item2 = Trim(Item2)
            If Item2 = "" Then GoTo Next2
            If UCase(Item1) = UCase(Item2) Then
                Found1 = 1
                Exit For
            End If
Next2:
        Next
        If Found1 = 0 Then
            If UniList > "" Then UniList = UniList & Sepa
            UniList = UniList & Item1
        End If
Next1:
    Next
    List_ItemsUnique = UniList
End Function

Function List_Compare(ANStrList1, ANStrList2, Optional CompareOrder = 0, Optional Sepa = "|")
   ' Compares between two ANStrList's
   ' Needs CutString3, ListCount
   '   If CompareOrder = 1 then lists should be in same order
   '   If 0 then order is not important
   ' Returns 1 if matched, 0 if not
   '
   Str1Co = ListCount(ANStrList1, Sepa, 0)
   Str2Co = ListCount(ANStrList2, Sepa, 0)
   Match1 = 0
   For I = 1 To Str1Co
      Item1 = Trim(CutString3(ANStrList1, I, Sepa))
      If CompareOrder = 1 Then
         Item2 = Trim(CutString3(ANStrList2, I, Sepa))
         If UCase(Item1) = UCase(Item2) Then Match1 = Match1 + 1
      ElseIf CompareOrder = 0 Then
         For J = 1 To Str2Co
            Item2 = Trim(CutString3(ANStrList2, J, Sepa))
            If UCase(Item1) = UCase(Item2) Then
               Match1 = Match1 + 1
               Exit For
            End If
         Next
      End If
   Next
   Match2 = 0
   For I = 1 To Str2Co
      Item1 = Trim(CutString3(ANStrList2, I, Sepa))
      If CompareOrder = 1 Then
         Item2 = Trim(CutString3(ANStrList1, I, Sepa))
         If UCase(Item1) = UCase(Item2) Then Match2 = Match2 + 1
      ElseIf CompareOrder = 0 Then
         For J = 1 To Str1Co
            Item2 = Trim(CutString3(ANStrList1, J, Sepa))
            If UCase(Item1) = UCase(Item2) Then
               Match2 = Match2 + 1
               Exit For
            End If
         Next
      End If
   Next
   Match3 = 0
   If Match1 = Str1Co And Match2 = Str2Co Then Match3 = 1
   List_Compare = Match3
End Function





Varies, but mostly
ANStrList, Sepa
or
ANStrList1, ANStrList2, Optional CompareOrder = 0, Optional Sepa = "|"

Views 4004 Downloads 1200

VBA Texts + Strings
ANmarAmdeen
755
Attachments
Revisions

v3.0