vba映射函数意外地表现

Question

为什么下面的函数有时可以工作而在其他函数中失败？

功能理念

• 字符串由用户或过程传递给此函数
• 该字符串将被多个分隔符拆分为一个单词数组
• 每个单词都是用非字母字符清除的，除了字符（单词中的短划线和单引号）之外，还有一个单词的例子。 （男人的精神，爱好生活）
• 如果在单词周围找到单引号，则它们也会被修剪
• 处理字符串中的每个单词后，如果该单词不为空，则会将其存储到数组 以及 中 的起始位置结束职位
• 开头和结尾位置是指 输入字符串 中的单词 的位置，不包括任何内容可能包含该单词的非字母字符。

这是代码

Sub test()
        Dim d$: d = ThisDocument.Range.Text
        Dim Arr(), i&
        Arr = ExtractWordsFromDoc_2(d)
        For i = 0 To UBound(Arr)
            ThisDocument.Range(Arr(i)(1) - 1, Arr(i)(2)).HighlightColorIndex = wdBrightGreen
        Next
    End Sub


Function ExtractWordsFromDoc_2(ByRef doc As Document, Optional ByVal Delimiters)
'   Take a string, and return it as a one dimensional array of individual arrys, each array
'   has three values (single delimited string, start range of delimited str, end range of delimited str)
'   the input string is delimited by any of several characters. None of those characters are returned in
'   the result. Provide a default list of Delimiters, which Should come from registry.
'   But allow override.
'===================================================================================================================
    Dim InputString$: InputString = doc.Range.Text
    'return an array of empty string when input string is empty
    If InputString = "" Then
        ExtractWordsFromDoc_2 = Array("", 0, 0)
        Exit Function
    End If
    '===================================================================================================================
    Dim DelimitList As Variant, ArrayOfWords() As Variant, TmpArr() As Variant
    Dim OneChar$, TempWord$, WordCount&, InputStringLength&, CharIndex&, ArrUbound&
    '===================================================================================================================
    'if delimiters are missing, We should get these from a Registry
    If IsMissing(Delimiters) Then
        DelimitList = Chr(34) & Chr(147) & Chr(148) & Chr(32) & "," & "." & vbCr & vbTab & "/" & "!" & "|" & ";" & ")" & "(" & "?"
        'Chr(34)= straight double quotes mark
        'Chr(147) & Chr(148) =opening and closing double quotes marks
        'Chr(32) = space
    Else
        DelimitList = Delimiters   'user can override if needed
    End If
    '===================================================================================================================
    InputStringLength = Len(InputString)    'get the input string length
    For CharIndex = 1 To InputStringLength    'loop through each character
        OneChar = VBA.Strings.Mid(InputString, CharIndex, 1)    'Read one character at a time
        Select Case InStr(DelimitList, OneChar)    'Test if the character is a delimiter character
        Case 0    'it is not a delimiter
            TempWord = TempWord & OneChar    'Add the character to the current word
        Case Is <> 0, Is = InputStringLength    'it is a delimiter or it is the last character
            'if the temp word is not empty and not a quotation mark
            If TempWord > "" And Not (TempWord = "'" Or TempWord = Chr(145) Or TempWord = Chr(146)) Then
                TmpArr = TrimSingQuotes(TempWord)    'send that word to be cleaned from single quotaion mark
                If (Not TmpArr(0) = "") Then    'if the returned word has length, count it
                    WordCount = WordCount + 1
                    ArrUbound = WordCount - 1  'set the new upper dimension for the storing array
                    ReDim Preserve ArrayOfWords(ArrUbound)    'expand storing array when we have a cleaned word with length
                    'Save new word in the last place inside the array, along with the word start and end ranges
                    ArrayOfWords(ArrUbound) = Array(TmpArr(0), _
                                                    CharIndex - Len(TempWord) + TmpArr(1) - 1, _
                                                    CharIndex - Len(TempWord) + TmpArr(2) - 1)
                End If
                TempWord = ""    'reset the Temp Word
            End If
        End Select
    Next CharIndex
'===================================================================================================================
    ExtractWordsFromDoc_2 = ArrayOfWords    'Return the storing array through function name
    'do some cleaning
    Erase ArrayOfWords
    Erase TmpArr
End Function

Sub testTrimSingQuotes()
    TrimSingQuotes (Empty)
End Sub

Function TrimSingQuotes(ByVal TempWord$)
'SSQP =starting single quote position
'ESQP = ending single quote position
'==================================================================
    If TempWord = "" Then
        TrimSingQuotes = Array("", 0, 0)
        Exit Function
    End If
    '==================================================================
    Dim SSQP&: SSQP = 1
    Dim ESQP&: ESQP = Len(TempWord)
    '==================================================================
    'trim starting single quotes
    Do While (Mid(TempWord, SSQP, 1) = "'" Or Mid(TempWord, SSQP, 1) = Chr(145) Or Mid(TempWord, SSQP, 1) = Chr(146)) And SSQP < ESQP
        SSQP = SSQP + 1
    Loop
    '==================================================================
    'trim ending single quotes
    Do While (Mid(TempWord, ESQP, 1) = "'" Or Mid(TempWord, ESQP, 1) = Chr(145) Or Mid(TempWord, ESQP, 1) = Chr(146)) And (ESQP > SSQP)
        ESQP = ESQP - 1
    Loop
    '==================================================================
    'get the trimmed word
    TempWord = Mid(TempWord, SSQP, ESQP - SSQP + 1)
    '==================================================================
    'test the trimmed word for output
    If TempWord > "" And Not (TempWord = "'" Or TempWord = Chr(145) Or TempWord = Chr(146)) Then
        TrimSingQuotes = Array(TempWord, SSQP, ESQP)
    Else
        TrimSingQuotes = Array("", 0, 0)
    End If
End Function

Answer 1

说实话，我没有花很多时间（即没有）弄清楚为什么你的代码没有按预期工作。我怀疑它与计算输入字符串中的位置有关。

利用Split函数中的构建来完成繁重工作更加简单 更简单，并且可能比依赖Instr和{等字符串函数更高效。 {1}}。请注意，这取决于Mid函数的2个怪癖：

首先，如果在空字符串上调用Split，它将返回一个Split为-1的数组。

其次，VBA的UBound版本不会删除空条目 - 因此，Split会生成数组{vbNullString，vbNullString}。这很好，因为根据结果数组的大小，您可以根据结果判断字符串中有多少分隔符（输入中的分隔符数总是等于数组元素的数量减去1。在VBA术语中，{{ 1}}。

您的要求使您的分隔符全部为1个字符。

尝试这样的事情：

Split("foo", "foo")

测试代码：

delimiterCount = UBound(Split(inputString, delimiter))

请注意，我甚至没有检查现有代码，以确定您的输出位置是基于1还是0。以上示例基于0。如果您需要1个，请在Private Function MultiSplit(inValue As String, delimiters() As Variant) As Variant() Dim output() As Variant Dim bound As Long ReDim Preserve output(bound) Dim tokens() As String Dim index As Long tokens = Split(inValue, delimiters(0)) If UBound(tokens) = -1 Then MultiSplit = Array(vbNullString, 0, 0) Exit Function End If 'Process each delimiter. For index = 1 To UBound(delimiters) tokens = SubSplit(tokens, CStr(delimiters(index))) Next index Dim position As Long For index = LBound(tokens) To UBound(tokens) If tokens(index) = vbNullString Then 'This means a delimiter was removed, so increment the position to account for it. position = position + 1 Else 'Resize the output array and write the result for the remaining token. ReDim Preserve output(bound) output(bound) = Array(tokens(index), position, position + Len(tokens(index)) - 1) position = position + Len(tokens(index)) + 1 bound = bound + 1 End If Next index MultiSplit = output End Function Private Function SubSplit(inValue() As String, delimiter As String) As String() Dim tokens() As String Dim substring As Variant Dim token As Variant Dim output() As String output = Split(vbNullString) For Each substring In inValue tokens = Split(substring, delimiter) 'Test for an empty token - these need to be preserved in the output. If UBound(tokens) = -1 Then ReDim Preserve output(UBound(output) + 1) Else For Each token In tokens ReDim Preserve output(UBound(output) + 1) output(UBound(output)) = token Next token End If Next substring SubSplit = output End Function 之后插入Private Function TestCode() Dim delims() As Variant Dim results() As Variant Dim test As String delims = Array(Chr(34), Chr(147), Chr(148), Chr(32), ",", ".", vbCr, vbTab, "/", "!", "|", ";", ")", "(", "?") test = "foo|||bar,,baz?crux" results = MultiSplit(test, delims) Dim result As Variant For Each result In results Debug.Print result(0) & vbTab & result(1) & vbTab & result(2) Next result End Function 。

引用删除是留给读者的练习。