VBA to auto populate cell based off specific text

[hmkisner]

I currently have a data validation drop down list incolumns F,G,J and R. If an option in 1 or any of those four columns is selectedand contains “(1)” within the text, I want the cell in column S toautomatically populate with the same data from the cell in column T.<o></o>
This has to VBA nota formula. I currently have a formula in Column S that the above VBA will needto override if “(1)” is found in F,G,J orR. If “(1)” is not found I want theVBA code to do nothing. But if a cell is changed from text containing “(1)” totext that is not containing it, I would like it to re-insert my orginal formula Ihad in column S.

The code is what I have so far, but its changing column S regardless of what is in Column R simply because of the change event. Im not sure how to specify that only contains text with (1). I also tried making my range a union and it does not register changes made in columns F,G, or J. PLEASE HELP!!!

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
' Only look at single cell changes
If Target.Count > 1 Then Exit Sub
Set rng = Range("R:R")
' Only look at that range
If Intersect(Target, rng) Is Nothing Then Exit Sub
' Copies the values entered into column B into C
Target.Offset(, 1).FormulaR1C1 = "=RC[1]"
End Sub

 

[JLGWhiz]

the post is a little confusing, but try this and post back with what needs to be fixed. I put a message box in for the formula replacement in column S, since I have no idea of what might have been there before, and the current transaction is not what originally deleted the formula.

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Value = "" Or Target.Cells.Count > 1 Then Exit Sub
Application.EnableEvents = False
Dim rng As Range
Set rng = Union(Range("F:F"), Range("G:G"), Range("J:J"), Range("R:R"))
    If Not Intersect(Target, rng) Is Nothing Then
        If Target.Value = "(1)" Then
            Range("S" & Target.Row) = Range("T" & Target.Row).Value
        ElseIf Target.Value <> "(1)" And Target.Value <> "" Then
            MsgBox "Cell " & Range("S" & Target.Row).Address & " needs formula restored. "
        End If
    End If
Hndl:
If Err.Number > 0 Then
    MsgBox Err.Description
    On Error GoTo 0
    Err.Clear
End If
Application.EnableEvents = True
End Sub

 

[hmkisner]

Thank you so much for the response! Unfortunately, the code did not work. It worked on the intial try and then just kept giving me the message box for everything I did in the spreadsheet. I would have responded sooner but was having issues on the site for some reason. After A LOT of research I went another route that is working correctly, however, it is slow. Can you help me adjust it so that it is still working accurately but not lagging?

Private Sub Worksheet_Change(ByVal Target As Range)

Dim SrchRng As Range, cel As Range
Dim SrchRng2 As Range
Dim SrchRng3 As Range
Dim SrchRng4 As Range

Application.EnableEvents = False


Set SrchRng = Range("F:F")
Set SrchRng2 = Range("G:G")
Set SrchRng3 = Range("J:J")
Set SrchRng4 = Range("R:R")


For Each cel In SrchRng
If InStr(1, cel.Value, "(1)") > 0 Then
cel.Offset(0, 13).Value = "=RC[1]"
End If
Next cel

For Each cel In SrchRng2
If InStr(1, cel.Value, "(1)") > 0 Then
cel.Offset(0, 12).Value = "=RC[1]"
End If
Next cel

For Each cel In SrchRng3
If InStr(1, cel.Value, "(1)") > 0 Then
cel.Offset(0, 9).Value = "=RC[1]"
End If
Next cel

For Each cel In SrchRng4
If InStr(1, cel.Value, "(1)") > 0 Then
cel.Offset(0, 1).Value = "=RC[1]"
End If
Next cel


Finalize:
Application.EnableEvents = True

End Sub

 

[JLGWhiz]

This will help a little bit, but four loops will still take some time.

Set SrchRng = Range("F1", Cells(Rows.Count, "F").End(xlUp))
 Set SrchRng2 = Range("G1", Cells(Rows.Count, "G").End(xlUp))
 Set SrchRng3 = Range("J1", Cells(Rows.Count, "J").End(xlUp))
 Set SrchRng4 = Range("R1", Cells(Rows.Count, "R").End(xlUp))

this will only check the cells in the range that contains data instead of all the empty cells beneath them as the original code was doing.