vba - VBA : Search, save and replace by rows according to conditions

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个字符/整数保存为i，将第二个“KP”之后的6个字符/整数保存为k。然后搜索整个数据集(A列中的数百行)是否包含字符串i，如果是，则将其替换为字符串k。并以此循环。因此，它将对以“kap”开头的另一行执行相同的操作。该代码给我错误消息:第二次涉及“Columns(“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