If row contains a string copy that row and add string text to cells in it.

**Vestax159** · 01-17-2010, 02:55 PM

So heres what I need to do. Search a column to see if it contains a string say "ItemA" anywhere in that cell. If it does then copy that row into a new row and add that string to several cells in the new row.

Case "ItemA"
        Copy String to the end of record
        Get column A of row I just copied and add "ItemA" to the begining

Thnx in advance for the help!

**shg** · 01-17-2010, 03:53 PM

An example workbook would help.

**Vestax159** · 01-17-2010, 08:09 PM

Sure


Original Row
                   A                                         B 
This text contains the word Dogs                        Cats, Birds

Pasted Row
                   A                                         B
This text contains the word Dogs                    Dogs, Cats, Birds

So basically do the above.

**pike** · 01-17-2010, 10:15 PM

adapt this regular

Sub ptestp()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim FoundOne As Range, LookInR As Range, LookForR As Range, c As Range
    Dim nr3    As Long, fAddress
    Application.ScreenUpdating = False
    Set ws1 = Sheets("Sheet7")
    Set ws2 = Sheets("Sheet8")

    Set LookInR = ws1.Range("A2:A10")
    Set LookForR = Range(ws2.Range("A2"), ws2.Range("A" & Rows.Count).End(xlUp))

    For Each c In LookForR
        With LookInR
            Set FoundOne = .Find(What:=c, lookat:=xlPart)
         
            If Not FoundOne Is Nothing Then
                fAddress = FoundOne.Address
              
                Do
                 
                FoundOne.Offset(0, 1).Value = c.Value & IIf(FoundOne.Offset(0, 1) <> "", ", ", " ") & FoundOne.Offset(0, 1)
                      Set FoundOne = .FindNext(After:=FoundOne)
                Loop While FoundOne.Address <> fAddress
            End If
        End With
    Next c
    Set ws1 = Nothing
    Set ws2 = Nothing
    Set LookInR = Nothing: Set LookForR = Nothing
    Application.ScreenUpdating = True
End Sub