Convert an array to a string and a string to an array

Option Explicit

'Purpose : Converts a 1d or 2d array to a deliminated String
'Inputs : avInArray The array to convert to a string
' sDelimRows Delimeter to seperate rows
' sDelimCols Delimeter to seperate columns (for 2d arrays)
'Outputs : A string containing all the elements of avInArray seperated by sDelimRows
'Notes :

Function ArrayToString(avInArray As Variant, Optional sDelimRows As String = "æ", Optional sDelimCols As String = "") As String
Dim lThisItem As Long, lNumItems As Long, lFirstRow As Long, lLastRow As Long
Dim lThisRow As Long, lThisCol As Long, lFirstCol As Long, lLastCol As Long

On Error GoTo ExitProc
Select Case ArrayNumDimensions(avInArray)
Case 0
'Empty array
Case 1
'1D Array
For lThisItem = LBound(avInArray) To UBound(avInArray)
ArrayToString = ArrayToString & (CStr(avInArray(lThisItem)) & sDelimRows) 'Join the small to the large
Next
Case 2
'2D Arrays
lFirstRow = LBound(avInArray, 2)
lLastRow = UBound(avInArray, 2)
lFirstCol = LBound(avInArray, 1)
lLastCol = UBound(avInArray, 1)
'Loop over each column then row to create the result string
For lThisCol = lFirstCol To lLastCol
For lThisRow = lFirstRow To lLastRow
ArrayToString = ArrayToString & (CStr(avInArray(lThisCol, lThisRow)) & sDelimRows) 'Join the small to the large
Next
ArrayToString = ArrayToString & sDelimCols
Next
Case Else
MsgBox "ArrayToString: Invalid array structure"
End Select

ExitProc:
On Error GoTo 0
End Function

'Purpose : Converts a string to string array.
'Inputs : sThisString The string to convert to an array
' asResults String array containing results
' sDelimRows Delimeter to seperate rows
' sDelimCols Delimeter to seperate columns (for 2d arrays)
'Outputs : N/A
'Notes :
'Revisions :

Sub StringToArray(ByVal sThisString As String, asResults() As String, Optional sDelimRows As String = "æ", Optional sDelimCols As String = "")
Dim lPos1dDel As Long, lPos2dDel As Long, lLenString As Long, lColSepLen As Long
Dim lLastPos As Long, lNumCols As Long, lThisRow As Long, lThisCol As Long, lRowSepLen As Long

lLenString = Len(sThisString)

If lLenString Then
lLastPos = 1
lPos1dDel = InStr(1, sThisString, sDelimRows)
lPos2dDel = InStr(1, sThisString, sDelimCols)
lNumCols = StringCount(sThisString, sDelimCols, vbTextCompare)
lRowSepLen = Len(sDelimRows)

If lNumCols Then
'Convert a 2d string
lThisCol = 1
lColSepLen = Len(sDelimCols)
'Create buffer to store results
On Error GoTo 0
ReDim asResults(1 To lNumCols, 1 To Int(lLenString / 2))
Do While lPos1dDel
lThisRow = lThisRow + 1
If lPos1dDel > lPos2dDel Then
'Next Column
lThisCol = lThisCol + 1
lThisRow = 0
lPos2dDel = InStr(lPos2dDel + 1, sThisString, sDelimCols)
lLastPos = lLastPos + lColSepLen
Else
'Store Row
asResults(lThisCol, lThisRow) = Mid$(sThisString, lLastPos, lPos1dDel - lLastPos)
lLastPos = lPos1dDel + lRowSepLen
End If
lPos1dDel = InStr(lLastPos, sThisString, sDelimRows)
Loop
ReDim Preserve asResults(1 To lNumCols, 1 To lThisRow)
Else
'Convert a 1d string
'Create buffer to store results
ReDim asResults(1 To Int(lLenString / 2))
lPos1dDel = InStr(lLastPos, sThisString, sDelimRows)
Do While lPos1dDel
lThisRow = lThisRow + 1
asResults(lThisRow) = Mid$(sThisString, lLastPos, lPos1dDel - lLastPos)
lLastPos = lPos1dDel + lRowSepLen
lPos1dDel = InStr(lLastPos, sThisString, sDelimRows)
Loop
ReDim Preserve asResults(1 To lThisRow)
End If
Else
Erase asResults
End If
End Sub

'Purpose : Calculates the number of dimensions in an array
'Inputs : avInArray. The array to evaluate.
'Outputs : The number of dimensions the array has.
'Notes :

Function ArrayNumDimensions(avInArray As Variant) As Long
Dim lNumDims As Long

If IsArray(avInArray) Then
On Error GoTo ExitSub
Do
lNumDims = UBound(avInArray, ArrayNumDimensions + 1)
ArrayNumDimensions = ArrayNumDimensions + 1
Loop
End If

ExitSub:
On Error GoTo 0
End Function

'Purpose : Count the number of matching instances of one string within another
'Inputs : sSearchString The string to search
' sForItem The string to search for
' [tCompare] The method of comparison. Defaults to a case insensative search.
' Can also specify vbBinaryCompare.
'Outputs : Returns the number of instances of the sForItem within sSearchString
'Notes :
'Revisions :

Function StringCount(sSearchString As String, sForItem As String, Optional tCompare As Long = vbTextCompare) As Long
Dim lPos As Long, lLenItem As Long

lLenItem = Len(sForItem)
Do
lPos = InStr(lPos + lLenItem, sSearchString, sForItem, tCompare)
If lPos Then
StringCount = StringCount + 1
Else
Exit Do
End If
Loop
End Function