Macro to find a text string within a larger body of text, in each cell of a column of cells, then copy and paste that text string into adjacent cells

[Drivelservant]

I need to write a macro that will search each cell in a column for the text "col", then copy that text and the seven characters to its right, and paste it into the cell adjacent and to the right of the searched cell. The search cannot be case sensitive. Any copy-and-pastable suggestions.

Hope I've explained this clearly. Thank you in advance for your time.

 

[skywriter]

You can try this.

Change the "A" to whatever column you desire, leave the "", they are needed.

Sub Drivelservant()
Dim rngFound As Range, strFirst As String
Application.ScreenUpdating = False
    With ActiveSheet.Columns("A")
        Set rngFound = .Find(What:="col", LookAt:=xlPart, SearchDirection:=xlNext, After:=.Cells(1), MatchCase:=False)
            If Not rngFound Is Nothing Then
                strFirst = rngFound.Address
                rngFound.Offset(, 1).Value = Mid(rngFound, InStr(1, rngFound, "col"), 10)
            Else
                MsgBox "No matches found"
                Application.ScreenUpdating = True
                Exit Sub
            End If
        Do
            Set rngFound = .FindNext(rngFound)
                If Not rngFound Is Nothing And strFirst <> rngFound.Address Then
                     rngFound.Offset(, 1).Value = Mid(rngFound, InStr(1, rngFound, "col", vbTextCompare), 10)
                Else
                    Application.ScreenUpdating = True
                    Exit Sub
                End If
        Loop
    End With
End Sub

 

[Rick Rothstein]

If you have less than, say, 5000 rows of original data (as a rough guess), then this should work for you...

[table="width: 500"]
[tr]
	[td]Sub CopyConPlus7()
  Dim LastRow As Long, Cons As Variant
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Cons = Split(Application.Trim(Join(Application.Transpose(Evaluate(Replace("IFERROR(MID(A1:A#,SEARCH(""con"",A1:A#),10),"""")", "#", LastRow))))))
  Range("B1").Resize(UBound(Cons) + 1) = Application.Transpose(Cons)
End Sub[/td]
[/tr]
[/table]

 

[skywriter]

You should use this version instead of the above version.

Sub Drivelservant()
Dim rngFound As Range, strFirst As String
Application.ScreenUpdating = False
    With ActiveSheet.Columns("A")
        Set rngFound = .Find(What:="col", LookAt:=xlPart, SearchDirection:=xlNext, After:=.Cells(1), MatchCase:=False)
            If Not rngFound Is Nothing Then
                strFirst = rngFound.Address
                rngFound.Offset(, 1).Value = Mid(rngFound, InStr(1, rngFound, "col", vbTextCompare), 10)
            Else
                MsgBox "No matches found"
                Application.ScreenUpdating = True
                Exit Sub
            End If
        Do
            Set rngFound = .FindNext(rngFound)
                If Not rngFound Is Nothing And strFirst <> rngFound.Address Then
                     rngFound.Offset(, 1).Value = Mid(rngFound, InStr(1, rngFound, "col", vbTextCompare), 10)
                Else
                    Application.ScreenUpdating = True
                    Exit Sub
                End If
        Loop
    End With
End Sub

 

[Drivelservant]

Thanks to both Rick and skywriter, both these solutions work perfectly. You have no idea how much time this has saved me, thanks again chaps.

 

[skywriter]

My pleasure, thanks for the feedback.

In my post #4, I meant you should use that version of my code if you so choose.

When I read it now it looks like I'm saying don't use Rick's.