搜索并替换字符串中的文本

Question

我使用下面的代码来搜索和替换字符串中的部分文本。它适用于几乎 97% 的替换，但当要替换的一个字符串与字符串的另一部分相同时则不然。有没有一种简单的方法可以避免这种情况？

Sub Macro1()

Dim i As Integer

For i = 2 To Worksheets("table1").Range("A1").End(xlDown).Row

Worksheets("table1").Range("H:H").Replace What:=Worksheets("table2").Range("A" & i), Replacement:=Worksheets("table2").Range("B" & i), LookAt:= _
    xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    
Next i

End Sub

重要提示：分隔符并不总是“,”。它也可以是带有逗号的任意组合空格。例子：

”、“
”、“
”、“

Answer 1

这就是所谓的误报。如果分隔符总是,，则分割字符串。进行替换，然后再次加入它们。

\n

这就是你正在尝试的吗？我已经评论了代码。如果您仍有疑问，请直接提问。

\n

Option Explicit\n\n\'~~> This is the delimiter. Change as applicable\nPrivate Const Delim As String = ","\n\nSub Sample()\n    Dim wsTblA As Worksheet\n    Dim wsTblB As Worksheet\n    \n    Dim lRow As Long\n    Dim i As Long, j As Long\n\n    Dim ArTable1 As Variant\n    Dim ArTable2 As Variant\n    \n    \'~~> Change this to the relevant worksheet\n    Set wsTblA = Worksheets("Table2")\n    Set wsTblB = Worksheets("Table1")\n    \n    \'~~> Get the values in Col A and B from Sheet Table2 in an array\n    With wsTblA\n        lRow = .Range("A" & .Rows.Count).End(xlUp).Row\n        \n        ArTable2 = .Range("A2:B" & lRow).Value2\n    End With\n    \n    \'~~> Get the values in Col H from Sheet Table1 in an array\n    With wsTblB\n        lRow = .Range("H" & .Rows.Count).End(xlUp).Row\n        \n        ArTable1 = .Range("H2:H" & lRow).Value2\n    End With\n    \n    \'~~> Loop through the array\n    For i = LBound(ArTable2) To UBound(ArTable2)\n        For j = LBound(ArTable1) To UBound(ArTable1)\n            \'~~> Check if the search string is present\n            If InStr(1, ArTable1(j, 1), ArTable2(i, 1), vbTextCompare) Then\n                \'~~> If it is present then attempt a replace\n                ArTable1(j, 1) = ReplaceText(ArTable1(j, 1), ArTable2(i, 1), ArTable2(i, 2))\n            End If\n        Next j\n    Next i\n    \n    \'~~> Write the array back to the worksheet\n    wsTblB.Range("H2").Resize(UBound(ArTable1), 1).Value = ArTable1\nEnd Sub\n\n\'~~> Function to split the text and then compare. If exact match, then replace\nPrivate Function ReplaceText(CellValue As Variant, ReplaceWhat As Variant, ReplaceWith As Variant) As String\n    Dim tmpAr As Variant\n    Dim ReplacedText As String\n    Dim k As Long\n    \n    \'~~> Split the test using the delimiter\n    tmpAr = Split(CellValue, Delim)\n    \n    \'~~> If exact match, then replace\n    For k = LBound(tmpAr) To UBound(tmpAr)\n        If UCase(Trim(tmpAr(k))) = UCase(Trim(ReplaceWhat)) Then\n            tmpAr(k) = ReplaceWith\n        End If\n    Next k\n    \n    \'~~> Rejoin using delimiter\n    ReplacedText = Join(tmpAr, Delim)\n    ReplaceText = ReplacedText\nEnd Function\n

\n

表2

\n

\n

表1

\n

\n

表 1 输出

\n

\n

编辑

\n

\n

感谢您提供的精彩解决方案。问题是分隔符并不总是“,”。也可以是空格“”。使用空格作为附加分隔符的问题可能是字符串的每个元素（例如“4711 Text_A”）在前 4 个字符之后始终有一个空格。\xe2\x80\x93 D3merzel 44 分钟前

\n

\n

在这种情况下，您可以采取另一种方法。文本可以出现在 3 个位置。开头（TEXT & Delim）、中间（Delim & TEXT & Delim）、结尾（Delim & TEXT）

\n

你可以尝试下面的代码吗？我还没有对其进行广泛的测试。如果您发现它不起作用的场景然后分享它，我将调整代码。

\n

Option Explicit\n\n\'~~> This is the delimiter. Change as applicable\nPrivate Const Delim As String = " "\n\nSub Sample()\n    Dim wsTblA As Worksheet\n    Dim wsTblB As Worksheet\n    \n    Dim lRow As Long\n    Dim i As Long, j As Long\n\n    Dim ArTable1 As Variant\n    Dim ArTable2 As Variant\n    \n    \'~~> Change this to the relevant worksheet\n    Set wsTblA = Worksheets("Table2")\n    Set wsTblB = Worksheets("Table1")\n    \n    \'~~> Get the values in Col A and B from Sheet Table2 in an array\n    With wsTblA\n        lRow = .Range("A" & .Rows.Count).End(xlUp).Row\n        \n        ArTable2 = .Range("A2:B" & lRow).Value2\n    End With\n    \n    \'~~> Get the values in Col H from Sheet Table1 in an array\n    With wsTblB\n        lRow = .Range("H" & .Rows.Count).End(xlUp).Row\n        \n        ArTable1 = .Range("H2:H" & lRow).Value2\n    End With\n    \n    \'~~> Loop through the array\n    For i = LBound(ArTable2) To UBound(ArTable2)\n        For j = LBound(ArTable1) To UBound(ArTable1)\n            \'~~> Check if the search string is present\n            If Left(ArTable1(j, 1), Len(ArTable2(i, 1) & Delim)) = ArTable2(i, 1) & Delim Then\n                ArTable1(j, 1) = Replace(ArTable1(j, 1), ArTable2(i, 1) & Delim, ArTable2(i, 2) & Delim)\n            ElseIf InStr(1, ArTable1(j, 1), Delim & ArTable2(i, 1) & Delim, vbTextCompare) Then\n                ArTable1(j, 1) = Replace(ArTable1(j, 1), Delim & ArTable2(i, 1) & Delim, Delim & ArTable2(i, 2) & Delim)\n            ElseIf Right(ArTable1(j, 1), Len(Delim & ArTable2(i, 1))) = Delim & ArTable2(i, 1) Then\n                ArTable1(j, 1) = Replace(ArTable1(j, 1), Delim & ArTable2(i, 1), Delim & ArTable2(i, 2))\n            End If\n        Next j\n    Next i\n    \n    \'~~> Write the array back to the worksheet\n    wsTblB.Range("H2").Resize(UBound(ArTable1), 1).Value = ArTable1\nEnd Sub\n

\n

表2

\n

\n

表1

\n

\n

表 1 输出

\n

\n

编辑

\n

上面的代码一次性处理了所有范围！但如果代码过于繁琐（不应该如此），上面的代码可以简化为一个函数来处理单个字符串。人们可以使用此函数来检查是否使用单个字符串正确进行了替换。例如

\n

Debug.Print SidRepcl("bbb b_ bb b__ ccc_ bb b_ ccc", "ccc_", "ccc", " ")\n

\n

输出：bbb b_ bb b__ ccc bb b_ ccc

\n

正如我之前提到的，我上面的所有代码都基于以下逻辑

\n

逻辑：文本可以出现在 3 个位置。开头（TEXT & Delim）、中间（Delim & TEXT & Delim）、结尾（Delim & TEXT）

\n

Option Explicit\n\nFunction SidRepcl(txt As String, srch As String, repl As String, Delim As String) As String\n    Dim i As Long\n    Dim RetVal As String: RetVal = txt\n    \n    \'~~> Check if the search string is present\n    If Left(txt, Len(srch & Delim)) = srch & Delim Then\n        RetVal = Replace(txt, srch & Delim, repl & Delim)\n    ElseIf InStr(1, txt, Delim & srch & Delim, vbTextCompare) Then\n        RetVal = Replace(txt, Delim & srch & Delim, Delim & repl & Delim)\n    ElseIf Right(txt, Len(Delim & srch)) = Delim & srch Then\n        RetVal = Replace(txt, Delim & srch, Delim & repl)\n    End If\n\n    SidRepcl = RetVal\nEnd Function\n

\n

Answer 2

替换分隔字符串

主要的

Sub ReplaceData()

    Const SRC_DELIMITER As String = ","
    Const DST_DELIMITER As String = ", "

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
 
    ' Write the values from the source range to an array.
    
    Dim sws As Worksheet: Set sws = wb.Sheets("Table2")
    If sws.AutoFilterMode Then sws.AutoFilterMode = False ' turn off AutoFilter
    
    Dim srg As Range
    Set srg = sws.Range("A2:B" & sws.Cells(sws.Rows.Count, "A").End(xlUp).Row)
    
    Dim Data(): Data = srg.Value
    
    ' Sort the array by length descending so that the longer strings
    ' are first matched to avoid finding shorter strings before longer ones.
    BubbleSortDataByLen Data, 1, True
    
    ' Write the unique values from the array to a dictionary.
    Dim dict As Object: Set dict = TwoColumnsToDictionary(Data, 1, 2)
    
    ' Write the values from the destination range to an array.
    
    Dim dws As Worksheet: Set dws = wb.Sheets("Table1")
    If dws.AutoFilterMode Then dws.AutoFilterMode = False ' turn off AutoFilter
    
    Dim drg As Range
    Set drg = dws.Range("H2", dws.Cells(dws.Rows.Count, "H").End(xlUp))
    
    Data = drg.Value
    
    ' Replace.
    ReplaceSingleColumnData Data, dict, SRC_DELIMITER, DST_DELIMITER
        
    ' Write back to the range.
    drg.Value = Data
        
    ' Inform
    MsgBox "Data replaced.", vbInformation

End Sub

种类

Sub BubbleSortDataByLen( _
        ByRef Data() As Variant, _
        ByVal SortColumnIndex As Long, _
        Optional ByVal Descending As Boolean = False)
    
    Dim rLB As Long, rUB As Long: rLB = LBound(Data, 1): rUB = UBound(Data, 1)
    Dim cLB As Long, cUB As Long: cLB = LBound(Data, 2): cUB = UBound(Data, 2)
    
    Dim T, i As Long, j As Long, c As Long, IsNotsorted As Boolean
    
    For i = rLB To rUB - 1
        For j = rLB + 1 To rUB
            If Descending Then
                If Len(CStr(Data(i, SortColumnIndex))) < Len(CStr( _
                    Data(j, SortColumnIndex))) Then IsNotsorted = True
            Else
                If Len(CStr(Data(i, SortColumnIndex))) > Len(CStr( _
                    Data(j, SortColumnIndex))) Then IsNotsorted = True
            End If
            If IsNotsorted Then
                For c = cLB To cUB
                   T = Data(i, c): Data(i, c) = Data(j, c): Data(j, c) = T
                Next c
            End If
        Next j
    Next i

End Sub

字典

Function TwoColumnsToDictionary( _
    Data() As Variant, _
    ByVal KeyColumnIndex As Long, _
    ByVal ItemColumnIndex As Long, _
    Optional ByVal MatchCase As Boolean = False) _
As Object
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = IIf(MatchCase, vbBinaryCompare, vbTextCompare)
    
    Dim r As Long, kStr As String
    
    For r = LBound(Data, 1) To UBound(Data, 1)
        kStr = CStr(Data(r, KeyColumnIndex))
        If Len(kStr) > 0 Then ' exclude blanks
            ' Use the first occurrences if any duplicates (shouldn't be any).
            If Not dict.Exists(kStr) Then
                dict(kStr) = CStr(Data(r, ItemColumnIndex))
            End If
        End If
    Next r
        
    If dict.Count = 0 Then Exit Function
    
    Set TwoColumnsToDictionary = dict
    
End Function

代替

Sub ReplaceSingleColumnData( _
        ByRef Data() As Variant, _
        ByVal dict As Object, _
        ByVal InDelimiter As String, _
        ByVal OutDelimiter As String)

    Dim r As Long, n As Long
    Dim sStrings() As String, sStr As String
    
    For r = LBound(Data, 1) To UBound(Data, 1)
        sStr = CStr(Data(r, 1))
        If Len(sStr) > 0 Then
            sStrings = Split(sStr, InDelimiter)
            For n = 0 To UBound(sStrings)
                sStr = Application.Trim(sStrings(n)) ' reusing 'sStr'
                If dict.Exists(sStr) Then
                    sStrings(n) = dict(sStr)
                Else
                    sStrings(n) = sStr
                End If
            Next n
            Data(r, 1) = Join(sStrings, OutDelimiter)
        End If
    Next r

End Sub

Answer 3

灵活的解决方案，可任意组合空格和逗号 (ta)

\n

作为 Siddharth 方法的替代方案，您可以通过以下方式更改逻辑

\n

\n
• \n
  \n
  1. 通过 \xe2\x96\xba搜索字符串本身分割输入文本，而不是应用标点符号分隔符，例如,或; ", "","" "
  \n
  \n
\n
• \n
  \n
  2. 检查当前标记中的最后一个字符和每个后续标记中的起始字符以执行替换。
  \n
  \n
\n

\n

以下（编辑于 2023-01-02）函数解决了评论中的附加要求：

\n

\n

...分隔符并不总是“,”。也可以是空格“”。使用空格作为附加分隔符的问题可能是字符串的每个元素（例如“4711 Text_A”）在前 4 个字符之后始终有一个空格

\n

\n

通过仅检查每个包含的搜索字符串的一个右或左相邻字符来查找" "或","（参见返回辅助函数结果IsMatch = curEndChar Like "[ ,]" And nxtStartChar Like "[ ,]" 以及对 function 的注释TMreplc()）。

\n

请注意，替换逻辑不仅仅关注这些明显的分隔符，还会将输入字符串（如eg）更改"4711 TEXT_A"为eg 4711 TEXT_A/1。

\n

Function TMreplc(txt As String, srch As String, repl As String) As String\n\'a) special case: replace entire text if identical to search string\n    If txt = srch Then TMreplc = repl: Exit Function\n\'b) get tokens by splitting via "search string" itself\n    Dim tokens: tokens = Split(txt, srch)\n    Dim ub   As Long:    ub = UBound(tokens)\n\'c) remember penultimate item\n    Dim mem  As String:  If ub > 0 Then mem = tokens(ub - 1)\n\'d) check most right token for content\n    Dim chk  As Boolean: chk = tokens(ub) = vbNullString\n    If chk And ub > 0 Then                       \n        tokens(ub - 1) = tokens(ub - 1) & IIf(Len(mem) = 0, srch, repl)\n        If ub = 1 And tokens(0) = vbNullString Then tokens(0) = repl\n    End If\n\'e) Check predecessing tokens for substitutability\n    Dim i As Long\n    For i = 0 To ub - IIf(chk, 2, 1)   \' if no srch finding at all (ignores: 0 To -1)\n        tokens(i) = tokens(i) & IIf(IsMatch(tokens, i), repl, srch)\n    Next i\n\'f) return result string\n    TMreplc = Join(tokens, vbNullString)\nEnd Function\n\n

\n

Function IsMatch(tokens, ByVal idx) As Boolean\n    Dim curEndChar As String\n    curEndChar = Right(IIf(idx = 0 And Len(tokens(0)) = 0, " ", "") & tokens(idx), 1)\n    Dim nxtStartChar As String: nxtStartChar = Left(tokens(idx + 1), 1)\n    \n    IsMatch = curEndChar Like "[ ,]" And nxtStartChar Like "[ ,]"\nEnd Function\n

\n

输出示例

\n

\n\n

历史

\n

我下面的第一次不完整尝试尝试通过仅检查以下字符来包含引用的附加要求，但没有考虑搜索字符串在当前标记中包含前面字符的情况。我将这次尝试保留为学习目的。-请参阅 Siddharth 的有用评论，它们为我指明了正确的方向。

\n

A. 第一次不完整的尝试

\n

Function replc(txt As String, srch As String, repl As String) As String\n\'a) split input text into tokens via srch delimiter\n    Dim tokens: tokens = Split(txt, srch)\n    Dim ub   As Long:    ub = UBound(tokens)\n\'b) check possible change in last search item     \n    Dim chg  As Boolean: chg = tokens(ub) = vbNullString\n    If chg Then tokens(ub - 1) = tokens(ub - 1) & repl\n\'c) modify tokens\n    Dim i    As Long\n    For i = 0 To ub - IIf(chg, 2, 1)\n         Dim nxtStartChar As String: nxtStartChar = Left(tokens(i + 1), 1)\n         tokens(i) = IIf(nxtStartChar Like "[ ,]", tokens(i) & repl, tokens(i) & srch)\n    Next i\n\'d) return joined tokens \n    replc = Join(tokens, vbNullString)\nEnd Function\n

\n\n

附加说明

\n

我如何尝试解决原始问题（最初不需要与 不同的分隔符）也可能具有启发性", "。请注意函数中的第二个参数Match()作为单个字符串值的数组传递。

\n

Function replc2(txt As String, srch As String, repl As String) As String\n    Dim tokens: tokens = Split(txt, ", ")\n    Dim mtch:   mtch = Application.Match(tokens, Array(srch), 0)\n    Dim i As Long\n    For i = 1 To UBound(mtch)\n        If IsNumeric(mtch(i)) Then tokens(i - 1) = repl\n    Next i\n    replc2 = Join(tokens, ", ")\nEnd Function\n\n

\n

B. 我的第二次尝试 （截至 2022 年 12 月 13 日）包括一个辅助函数IsMatch，但在某些情况下失败（例如，如果输入 txt 与搜索字符串 100% 相同 - 请参阅帖子顶部的最后编辑）；我将其包含在内只是为了比较的原因以完成历史记录：

\n

Function replc(txt As String, srch As String, repl As String) As String\nDim tokens: tokens = Split(txt, srch)\nDim i    As Long\nDim ub   As Long: ub = UBound(tokens)\nDim chg  As Boolean: chg = tokens(ub) = vbNullString\nIf chg Then tokens(ub - 1) = tokens(ub - 1) & repl\nFor i = 0 To ub - IIf(chg, 2, 1)\n    tokens(i) = tokens(i) & IIf(IsMatch(tokens, i), repl, srch)\nNext i\nreplc = Join(tokens, vbNullString)\nEnd Function\n

\n

功能IsMatch()- 参见帖子顶部

\n