VBA：根据条件按行搜索、保存和替换

Question

我有这样的输入：

gen,N,,,GONGD,,,N,,,KL,0007bd,,,,,,,,TAK,
gen,N,,,RATEC,,,N,,,KP,0007bc,,,,,,,,TAZ,
kap,N,,,EBFWE,N,,,,,,,,,KP,002bd4,,,KP,123000,,,,,N,,,,P
kap,N,,,ST,WEIT,E3,EBFWEI,,,KP,002bd2,N,,,,,,KP,002bd3,,,,,,,Z,MG00,,,,,N,,,,P

我有这样的代码：

Sub Find()
Dim rFoundAddress As Range
Dim sFirstAddress As String
Dim x As Long

With ThisWorkbook.Worksheets("Sheet1").Columns(1)
    Set rFoundAddress = .Find("kap,*", LookIn:=xlValues, LookAt:=xlWhole)
    If Not rFoundAddress Is Nothing Then
        sFirstAddress = rFoundAddress.Address
        Do
            Dim WrdArray() As String
            Dim text_string As String
            Dim i As String
            Dim k As String
            Dim num As Long
            text_string = rFoundAddress
            WrdArray() = Split(text_string, "KP,")
            i = Left(WrdArray(1), 6)
            k = Left(WrdArray(2), 6)

            Columns("A").Replace What:=i, _
                        Replacement:=k, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        MatchCase:=False, _
                        SearchFormat:=False, _
                        ReplaceFormat:=False

            Set rFoundAddress = .FindNext(rFoundAddress)
        Loop While Not rFoundAddress Is Nothing And _
            rFoundAddress.Address <> sFirstAddress
    End If
End With
End Sub

我正在尝试做的事情： 查找所有以“kap”开头的行，并将第一个“KP”之后的 6 个字符/int 保存为 i，将第二个“KP”之后的 6 个 chars/int 保存为 k。然后搜索整个数据集（A 列中的数百行）是否包含字符串 i，如果是，则将其替换为字符串 k。并循环这个。所以它会对以“kap”开头的另一行做同样的事情。该代码给了我错误消息：第二次涉及“列（“A”）...”时下标超出范围。你能帮帮我吗？

提前致谢

Answer 1

编辑以使所有搜索到的字符串都相同（“kap,*”）

你不想修改（通过Replace()）你循环的范围

所以在遍历范围时收集数组中所有需要的替换，然后遍历数组并进行替换

如下：

Option Explicit

Sub Find()
    Dim rFound As Range
    Dim sFirstAddress As String
    Dim val As Variant
    Dim nKap As Long

    With ThisWorkbook.Worksheets("Sheet1").Columns(1)
        nKap = Application.WorksheetFunction.CountIf(.Cells, "kap,*") '<--| count the occurrences of "kap,*"
        If nKap > 0 Then
            ReDim vals(1 To nKap) As Variant '<--| array that will collect all find/replace couples
            nKap = 0
            Set rFound = .Find("kap,*", LookIn:=xlValues, LookAt:=xlWhole)
            sFirstAddress = rFound.Address
            Do
                nKap = nKap + 1
                vals(nKap) = Split(Split(Split(rFound.text, "KP")(1), ",")(1) & "," & Split(Split(rFound.text, "KP")(2), ",")(1), ",") '<--| store the ith couple of find/replace values
                Set rFound = .FindNext(rFound)
            Loop While rFound.Address <> sFirstAddress

            For Each val In vals '<--| loop through values to be replaced array
                .Replace What:=val(0), _
                        Replacement:=val(1), _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        MatchCase:=False, _
                        SearchFormat:=False, _
                        ReplaceFormat:=False
             Next val
        End If


    End With
End Sub

Function GetValues(txt As String) As Variant
    If InStr(txt, "KP") > 0 Then GetValues = Split(Split(Split(txt, "KP")(1), ",")(1) & "," & Split(Split(txt, "KP")(2), ",")(1), ",")
End Function