Help With Existing Code

[Dazzawm]

I have this code that extracts data that is amongst data in cells in column J and puts it in Column K. But I need it to add it on the end of the data already in the destination cell rather than overwriting it. Thanks.

Sub ExtractData()
Dim REX         As Object '<--- RegExp
Dim rexMatch    As Object '<--- Match
Dim rexMatchCol As Object '<--- MatchCollection
Dim Cell        As Range
Dim strText     As String
    Set REX = CreateObject("VBScript.RegExp")
    With REX
        .Global = True
        .IgnoreCase = True 
        .Pattern = "JTD" '<---change to suit if
 
       For Each Cell In Range(Cells(2, "J"), Cells(Rows.Count, "J").End(xlUp))
            If .test(Cell.Value) Then
                Set rexMatchCol = .Execute(Cell.Value)
                Cell.Value = .Replace(Cell.Value, vbNullString)
                strText = vbNullString
                For Each rexMatch In rexMatchCol
                    strText = strText & Chr(32) & rexMatch.Value
                Next
                Cell.Offset(, 1).Value = Trim(strText)
            End If
        Next
    End With
End Sub

 

[Ruddles]

I think you just need to remove the line of code which empties the cell before you write to it:-

Cell.Value = .Replace(Cell.Value, vbNullString)

 

[ZPhantom]

Try

 Cell.Offset(, 1).Value = cell.offset(0,1).value & " " & Trim(strText)

ZP

 

[Dazzawm]

Thanks. FYI ZPhantom yours worked, sorry Ruddles yours didn't!