A recent post on the Tek-Tips VBA forum reminded me that VBA has a split function, which will split a string into sub-strings at any specified character (such as a space). D’oh I thought, why did I waste my time writing my own split function when it is there in VBA already? Then I remembered that if the string has multiple consecutive split characters (such as two or more consecutive spaces) the VBA split function will treat each of these as a separate sub-string, which is not normally what we want.
Writing a split function from scratch is one way around this problem, but the Microsoft on line documentation for VB gives an alternative. The suggested code here uses the VB split function, then copies each non-blank member of the resulting array to a new array. This works well if you want to split entire lines of text, but if you want to split only some of the text, and return the remainder as a single string, then this approach will not work. To avoid this problem I wrote the code shown below, which removes all duplicate instances of the separator string, then uses the VBA split function on the resulting string.
Function SplitText2(Texta As Variant, Optional NumCols As Long = -1, Optional Separator As Variant = " ") As Variant Dim NumLines As Long, i As Long, j As Long, Linea As Variant, Numwords As Long Dim MaxWords As Long, SplitString As String, SplitString2 As String, LenString As Long, SplitCount As Long, NextChar As String Dim AddChar As String, MaxCols As String</code> If LCase(Separator) = "tab" Then Separator = Chr(9) If Val(Separator) > 0 Then Separator = Chr(CLng(Separator)) Texta = GetArray(Texta) NumLines = UBound(Texta) - LBound(Texta) + 1 If NumCols = -1 Then MaxCols = 10 Else MaxCols = NumCols ReDim Preserve Texta(1 To NumLines, 1 To MaxCols) For i = 1 To NumLines ' Remove 2nd and subsequent consecutive separator characters SplitString2 = "" SplitString = Texta(i, 1) LenString = Len(SplitString) SplitCount = 0 For j = 1 To LenString NextChar = Mid(SplitString, j, 1) If NextChar = Separator Then If SplitCount = 0 Then SplitCount = 1 AddChar = NextChar Else AddChar = "" End If Else AddChar = NextChar SplitCount = 0 End If SplitString2 = SplitString2 & AddChar Next j 'Split text Linea = Split(SplitString2, Separator, NumCols) ' Add Linea to Texta Numwords = UBound(Linea) - LBound(Linea) + 1 If Numwords > MaxWords Then MaxWords = Numwords ReDim Preserve Texta(1 To NumLines, 1 To Numwords) End If For j = 0 To Numwords - 1 Texta(i, j + 1) = Linea(j) Next j Next i SplitText2 = Texta End Function Function SplitText2(Texta As Variant, Optional NumCols As Long = -1, Optional Separator As Variant = " ") As Variant Dim NumLines As Long, i As Long, j As Long, Linea As Variant, Numwords As Long Dim MaxWords As Long, SplitString As String, SplitString2 As String, LenString As Long, SplitCount As Long, NextChar As String Dim AddChar As String, MaxCols As String If LCase(Separator) = "tab" Then Separator = Chr(9) If Val(Separator) > 0 Then Separator = Chr(CLng(Separator)) Texta = GetArray(Texta) NumLines = UBound(Texta) - LBound(Texta) + 1 If NumCols = -1 Then MaxCols = 10 Else MaxCols = NumCols ReDim Preserve Texta(1 To NumLines, 1 To MaxCols) For i = 1 To NumLines ' Remove 2nd and subsequent consecutive separator characters SplitString2 = "" SplitString = Texta(i, 1) LenString = Len(SplitString) SplitCount = 0 For j = 1 To LenString NextChar = Mid(SplitString, j, 1) If NextChar = Separator Then If SplitCount = 0 Then SplitCount = 1 AddChar = NextChar Else AddChar = "" End If Else AddChar = NextChar SplitCount = 0 End If SplitString2 = SplitString2 & AddChar Next j 'Split text Linea = Split(SplitString2, Separator, NumCols) ' Add Linea to Texta Numwords = UBound(Linea) - LBound(Linea) + 1 If Numwords > MaxWords Then MaxWords = Numwords ReDim Preserve Texta(1 To NumLines, 1 To Numwords) End If For j = 0 To Numwords - 1 Texta(i, j + 1) = Linea(j) Next j Next i SplitText2 = Texta End Function
Note that this function lacks a couple of features found in my earlier Split function, but it does have the virtue of simplicity.