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 4782 Downloads 1474

VBA Texts + Strings
ANmarAmdeen
813
Attachments
Revisions

v3.0