VBA - 如何使用多个不同大小的分隔符构建数组？

Question

如果我有多个分隔符，一些分隔符是单个字符而另一些分隔符是多个字符，我如何构建一个数组呢？

Sub Example()
    Dim exString As String
    Dim myString() As String

    exString = "A,B C;D > E"

    myString() = Split(exString, "," & " " & ";" & " > ")
End Sub

我想要的数据是：

myString(0) is A
myString(1) is B
myString(2) is C
myString(3) is D
myString(4) is E

但以这种方式使用Split()并不起作用。我知道我可以使用Replace()用一个常用的分隔符替换每个分隔符，但是我有很多不同的分隔符和多个字符分隔符的变体。使用Replace()对我来说并不合适。我该怎么办？

Answer 1

您也可以在VBA中have lots of problems：

N

设置Number定义要查找的内容。 'Add a reference to Microsoft VBScript Regular Expressions 5.5 (Tools -> References...) Dim exString As String exString = "A,B C;D > E" Dim re As New RegExp re.Pattern = "(,| |;|>)+" re.Global = True Dim myString() As String myString = Split(re.Replace("A,B C;D > E", ","), ",") 表示找到re.Pattern，因此正则表达式将匹配|或A or B或,或。

多个实例应该被视为一个（例如，在;和>之间有三个字符，但应该只有一个分割），所以在{...}添加D结束（并在E中包装其他所有内容。）

+然后用()替换任何匹配的模式，并返回如下字符串：

  

A，B，C，d，E

我们可以简单地调用Replace来取回数组。

• 参考：VBScript Regular Expressions

您可以使用正则表达式匹配非分隔符字符，而不是使用正则表达式来匹配分隔符字符：

,

如果您只需要迭代结果并对它们执行某些操作，那么这就足够了。如果你特别需要一个包含结果的数组：

Split

Answer 2

在这种情况下，我发现以下功能可以满足我的需求：

Function MultiSplit(SourceText As String, Optional SingleCharDelimiter As String, Optional MultiCharDelimiter As String, _
    Optional Separator As String) As String()
'Created by Tyeler for use by all.
'SourceText is your input string.
'SingleCharDelimiter is a string of desired delimiters.
'SingleCharDelimiter format is a string fully concatenated with no character separation.
'  (ex. "-.;:, " MultiSplit will use those 6 characters as delimiters)
'SingleCharDelimiter's will remove blanks from the array in the event two single delimiters
'  are next to each other.
'MultiCharDelimiter is a string of specific multi-character delimiters.
'MultiCharDelimiters can be separated by the optional Separator
'Separator is an optional value used to separate multiple MultiCharDelimiters.
'  (ex. MultiCharDelimiter = "A A,B B,C C" // Separator = "," // This will make the function
'    delimit a string by "A A", "B B", and "C C")
'MultiSplit will make an array based on any delimiter (Including delimiters with
'  multiple characters).


    If MultiCharDelimiter = "" And SingleCharDelimiter = "" Then Exit Function
    Dim i As Integer, n As Integer, dlimit
    Dim delColl As New Collection
    Dim newString As String: newString = SourceText
    Dim delArr() As String, strgArr() As String, delFull() As String
    Dim delSep As String, a As Integer: a = 33

    Do While InStr(SingleCharDelimiter, Chr(a)) <> 0 Or InStr(MultiCharDelimiter, Chr(a)) <> 0 _
        Or InStr(Separator, Chr(a)) <> 0 Or InStr(SourceString, Chr(a)) <> 0 'Find intermediate delimiter
            a = a + 1
    Loop
    delSep = Chr(a)

    If MultiCharDelimiter <> "" Then
        If Separator <> "" Then 'If there's no delimiter for the delimiter array, assume MultiCharDelimiter is the delimiter
            delArr() = Split(MultiCharDelimiter, Separator)
            For i = 0 To UBound(delArr)
                If InStr(newString, delArr(i)) <> 0 Then newString = Replace(newString, delArr(i), delSep)
            Next i
        Else
            newString = Replace(newString, MultiCharDelimiter, delSep)
        End If
    End If
    Erase delArr

    For i = 1 To Len(SingleCharDelimiter) 'Build a collection of user defined delimiters
        delColl.Add Mid(SingleCharDelimiter, i, 1)
    Next i

    For Each dlimit In delColl 'Replace all delimiters in the string with a single common one
        newString = Replace(newString, dlimit, delSep)
    Next dlimit

    strgArr() = Split(newString, delSep)
    ReDim delFull(LBound(strgArr) To UBound(strgArr))
    n = LBound(strgArr)

    For i = LBound(strgArr) To UBound(strgArr) 'Get rid of empty array items
        If strgArr(i) <> "" Then
            delFull(n) = strgArr(i)
            n = n + 1
        End If
    Next i

    n = n - 1
    ReDim Preserve delFull(LBound(strgArr) To n)
    MultiSplit = delFull 'Send the delimited array
    Erase delFull
    Erase strgArr
End Function

此函数将返回由用户定义的分隔符分隔的值数组。

要使用此功能，只需调用它并提供完整的字符串和所需的分隔符：

Sub Example1()
    Dim exString As String
    Dim myString() As String
    Dim c, n

    exString = "A,B C;D > E"

    myString() = MultiSplit(exString, ", ;", " > ")
    n = 0
    For Each c In myString
        Debug.Print "(" & n & ") = " & c
        n = n + 1
    Next c
End Sub

这将产生所需的结果，其中数组仅填充ABCDE。

更复杂的例子：

Sub Example2()
    Dim myString As String, c, n

    n = 0
    myString = "The,Quickupside-downBrownjelloFox_Jumped[Over]             ThegiantLazyjelloDog"

    For Each c In MultiSplit(myString, ",_[] ", "upside-down,jello,giant", ",")
        Debug.Print "(" & n & ") = " & c
        n = n + 1
    Next c
End Sub

这将产生以下结果：

Answer 3

你的功能正确。使用ParamArray，您可以轻松更改分隔符的数量和位置。

代码

Function MultiSplit(SourceText As String, ParamArray Delimiters()) As String()
    Dim v As Variant

    For Each v In Delimiters
        SourceText = Replace(SourceText, v, "•")
    Next

    MultiSplit = Split(SourceText, "•")

End Function

测试

Sub Test()
    Const example As String = "A,B C;D > E"
    Dim a1, a2, a3, Incorrect

    Incorrect = MultiSplit(example, " ", " > ")
    a1 = MultiSplit(example, " > ", ",", ";", " ")
    a2 = MultiSplit(example, " > ", ",")
    a3 = MultiSplit(example, " > ")
End Sub

结果

注意：使用多字符分隔符时，分隔符的处理顺序很重要。请注意，A1已正确拆分但不正确未按预期拆分，因为空格分隔符位于" > "之前。

Answer 4

以下是Thomas Inzina慷慨提供的代码的内置版本。

以下限制已被删除：

• 分隔符在函数中列出的顺序。
• 临时分隔符是设置特定字符。
• 包含或删除空数组项的选项。
• 更改参考的函数（ByRef vs ByVal）
• 传递分隔符数组与列出单个分隔符

Function MultiSplitX(ByVal SourceText As String, RemoveBlankItems As Boolean, ParamArray Delimiters()) As String()
    Dim a As Integer, b As Integer, n As Integer
    Dim i As Integer: i = 251
    Dim u As Variant, v As Variant
    Dim tempArr() As String, finalArr() As String, fDelimiters() As String

    If InStr(TypeName(Delimiters(0)), "()") <> 0 And LBound(Delimiters) = UBound(Delimiters) Then
        ReDim fDelimiters(LBound(Delimiters(0)) To UBound(Delimiters(0))) 'If passing array vs array items then
        For a = LBound(Delimiters(0)) To UBound(Delimiters(0))            'build that array
            fDelimiters(a) = Delimiters(0)(a)
        Next a
    Else
        fDelimiters = Delimiters(0)
    End If

    Do While InStr(SourceText, Chr(i)) <> 0 And i < 251 'Find an unused character
        i = i + 1
    Loop
    If i = 251 Then 'If no unused character in SourceText, use single character delimiter from supplied
        For a = LBound(fDelimiters) To UBound(fDelimiters)
            If Len(fDelimiters(a)) = 1 Then i = Asc(fDelimiters(a))
        Next a
    End If
    If i = 251 Then 'If no single character delimiters can be used, error.
        MsgBox "SourceText uses all character type." & vbCrLf & "Cannot split SourceText into an array.", _
            vbCritical, "MultiSplitX Run-Time Error"
        Exit Function
    End If
    Debug.Print i


    For a = LBound(fDelimiters) To UBound(fDelimiters) 'Sort Delimiters by length
        For b = a + 1 To UBound(fDelimiters)
            If Len(fDelimiters(a)) < Len(fDelimiters(b)) Then
                u = fDelimiters(b)
                fDelimiters(b) = fDelimiters(a)
                fDelimiters(a) = u
            End If
        Next b
    Next a

    For Each v In fDelimiters 'Replace Delimiters with a common character
        SourceText = Replace(SourceText, v, Chr(i))
    Next

    tempArr() = Split(SourceText, Chr(i)) 'Remove empty array items
    If RemoveBlankItems = True Then
        ReDim finalArr(LBound(tempArr) To UBound(tempArr))
        n = LBound(tempArr)
        For i = LBound(tempArr) To UBound(tempArr)
            If tempArr(i) <> "" Then
                finalArr(n) = tempArr(i)
                n = n + 1
            End If
        Next i
        n = n - 1
        ReDim Preserve finalArr(LBound(tempArr) To n)

        MultiSplitX = finalArr
    Else: MultiSplitX = tempArr
    End If
End Function

使用此函数不会改变托马斯的使用方式，除了添加了布尔语句。

示例1

在此示例中，RemoveBlankItems已设置为True。

Sub Example1()
    Dim myString As String, c, n

    n = 0
    myString = "The,Quickupside-downBrownjelloFox_Jumped[Over]             ThegiantLazyjelloDog"

    For Each c In MultiSplitX(myString, True, ",", "-", "upside-down", "jello", " ", "[", "]", "giant", "_")
        Debug.Print "(" & n & ") = " & c
        n = n + 1
    Next c
End Sub

这导致以下输出：

示例2

在此示例中，我们将RemoveBlankItems设置为False。

Sub Example2()
    Dim myString As String, c, n

    n = 0
    myString = "The,Quickupside-downBrownjelloFox_Jumped[Over]             ThegiantLazyjelloDog"

    For Each c In MultiSplitX(myString, True, ",", "-", "upside-down", "jello", " ", "[", "]", "giant", "_")
        Debug.Print "(" & n & ") = " & c
        n = n + 1
    Next c
    Debug.Print myString
End Sub

这导致以下输出：

示例3

在这个例子中，我们不是在函数中列出我们的分隔符，而是在字符串中键入它们并在函数中插入一个数组：

Sub Example3()
    Dim myString As String, c, n
    Dim myDelimiters As String

    n = 0
    myString = "The,Quickupside-downBrownjelloFox_Jumped[Over]             ThegiantLazyjelloDog"
    myDelimiters = ",|-|upside-down|jello| |[|]|giant|_"

    For Each c In MultiSplitX(myString, True, Split(myDelimiters, "|"))
        Debug.Print "(" & n & ") = " & c
        n = n + 1
    Next c
    Debug.Print myString
End Sub

这与单独列出的结果相同：

原因RemoveBlankItems是理想的

在某些情况下，您不希望阵列中出现空白。例如，如果您将阵列用作在电子表格中循环播放范围的搜索字词库。另一个例子是，如果您根据数组中的值操作文本字符串。

有时候你想要保留数组中的空格。正如Thomas所描述的那样，如果你在CSV文件中使用它，那么需要将空格保持为列。或者您正在使用它来分解，例如，HTML编码并希望保留行格式。

Answer 5

也许：

Sub Example()

    Dim exString As String
    Dim myString() As String

    exString = "A,B C;D > E"
    exString = Replace(exString, ",", " ")
    exString = Replace(exString, ";", " ")
    exString = Replace(exString, ">", " ")
    exString = Application.WorksheetFunction.Trim(exString)

    myString() = Split(exString, " ")

    msg = ""
    For Each a In myString
        msg = msg & vbCrLf & a
    Next a

    MsgBox msg
End Sub