VBA: Search, save and replace by rows according to

Question

I have an input like this:

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

I have a code like this:

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

What I am trying to do: Find all lines starting with "kap" and save 6 chars/int after first "KP" as i and 6 chars/int after second "KP" as k. Then search the whole data-set (hundreds of rows in column A) if they contain string i and if yes, then replace it for string k. And to loop this. So it will do the same with another line starting with "kap". The code gives me error message: Subscript out of range when it comes to "Columns("A")..." for the second time. Can you help me please?

THANK YOU IN ADVANCE

Answer 1

edited to make all searched string occurrences the same ("kap,*")

you don't want to modify (via Replace()) the range you're looping through

so collect all needed replacements in an array while looping through the range and then loop through the array and make the replacements

like follows:

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