Link to home
Start Free TrialLog in
Avatar of Ted Penner
Ted PennerFlag for United States of America

asked on

Macro needed to append column A with input string if found

'If the row contains "a specific string" of characters then that specific string of characters should be appended to the end of the cell in the currently selected column.
'This should occur only if the cell in the selected column for the row in question does not already contain that string of characters.
'Also, if the specific string of characters is not found anywhere on the row, then it should not be appended.

Attached is a small sample contacts.xlsm

The actual sheet has many more rows and columns.
Avatar of Saqib Husain
Saqib Husain
Flag of Pakistan image

- Right-click on  the sheet tab name
- Select View code
- Paste the below code in the VBA window
- Close the VBA window

- Enter your key word in cell A1

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel As Range
If Target.Address = Range("A1").Address Then
    If Target.Value <> "Name" Then
    For Each cel In Range(Target.Offset(1), Target.End(xlDown))
        cel.Select
        If Not cel.Offset(, 1).Resize(, Columns.Count - 1).Find(Target.Value) Is Nothing Then
            cel.Value = cel.Value & " " & Target.Value
        End If
    Next cel
    End If
Target.Value = "Name"
End If
End Sub

Open in new window




Please show a picture of or attach a workbook that shows what you want it to look like after you enter craigslist.
ASKER CERTIFIED SOLUTION
Avatar of Robert Berke
Robert Berke
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Ted Penner

ASKER

Still not working as expected

This is the result so far https://www.screencast.com/t/4mmrpLke

Sub Append_macro()
Dim strFind As String
Dim tcell As Range
Dim fndcells(200) As String
Dim add As Boolean
Dim frst As String
Dim a As String
Dim lstrow As Integer
a = Left(Replace(ActiveCell.Address, "$", ""), 1)
lstrow = Range(a & Rows.Count).End(xlUp).Row

strFind = InputBox("Please Input Your Word(s)", "Input Word")
If strFind = "" Then Exit Sub

Set tcell = ActiveSheet.Cells.Find(What:=strFind, LookIn:=xlValues, LookAt:=xlPart, _
                        MatchCase:=False, searchOrder:=xlByRows)
If tcell Is Nothing Then
MsgBox "Not Found"
Exit Sub
Else
frst = tcell.Address
End If

i = 0
Do Until tcell Is Nothing
    fndcells(i) = tcell.Address

    'Debug.Print found.Address
    Set tcell = ActiveSheet.Cells.FindNext(tcell)

    If tcell.Address = frst Then
        Exit Do
    End If
    i = i + 1
Loop

For Each fnd In fndcells
If fnd = "" Then Exit For

    add = True
    For Each cell In Range(a & "1:" & a & lstrow)
   
        If cell.Value = Range(fnd).Value Then
        add = False
        End If
    Next
    If add Then
        Range(a & lstrow + 1).Value = Range(fnd).Value
        lstrow = lstrow + 1
    End If
Next
MsgBox "Done!"

End Sub

Open in new window


You have modified my macro considerably and your version has a few bugs.  I suggest you return to my original code.


Change line 48 of my original macro to be
.Value = .Value & " " & lookFor

Let me know if that does what you want.


If you prefer I can help you debug your new code, but please be sure it compiles with Option Explicit.

Also,  I would need to understand what you are doing with lstRow. It looks like it might add records to the bottom of your spread sheet. Is that what you want?