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 中遇到很多問題 ：

'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之間有三個字符，但只能有一個分割符），因此請在末尾添加+ （並將其他所有內容包裝在() ）。

Replace然后用替換任何匹配的模式,並返回如下字符串：

A，B，C，D，E

我們可以在其上簡單地調用Split來返回數組。

• 參考： VBScript正則表達式

---

除了使用正則表達式匹配分隔符之外，還可以使用正則表達式來匹配非分隔符：

Dim re As New RegExp
re.Pattern = "[^, ;>]+"   'The ^ unmatches any characters within the []
re.Global = True

Dim match As Match
For Each match In re.Execute(exString)
    'do something with each result here
    Debug.Print match.Value
Next

如果您只需要遍歷結果並對其進行處理，就足夠了。 如果您特別需要帶有結果的數組：

Dim re As New RegExp
re.Pattern = "[^, ;>]+"
re.Global = True

Dim matches As MatchCollection
Set matches = re.Execute(exString)
ReDim myString(matches.Count) As String
Dim i As Integer
For i = 0 To matches.Count - 1
    myString(i) = matches(i).Value
Next

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與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 

此功能的使用與Thomas的用法相同，只是添加了布爾語句。

---

例子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