Excel VBA: If cell contains certain text then input range of cells with that content

Question

Would like to have a column range searched for specific text ("REASON") and when found, have that entire cell content be filled onto a range of different cells.

This is done until a new "REASON" is found - in which case this cell content will be copied accordingly like before.

This is before result: before

... and expected result, with filled text in J column

Thanks guys, been messing with this but not sure where to go from here:

Sub AddSus()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("g1:g60")
For Each cel In SrchRng
  If InStr(1, cel.Value, "REASON") > 0 Then
     cel.Offset(1, 0).Value = cel.Value
  End If
Next cel
End Sub

Answer 1

Use FIND to quickly jump between instances of REASON :

Sub AddSus()

    Dim SrchRng As Range
    Dim rFound As Range
    Dim lStart As Long, lEnd As Long
    Dim sFirstAddress As String
    Dim sReason As String

    Set SrchRng = ThisWorkbook.Worksheets("Sheet1").Range("G:G")

    'Find the first instance of REASON in column G.
    Set rFound = SrchRng.Find(What:="REASON:", _
                       After:=SrchRng.Cells(1, 1), _
                       LookIn:=xlValues, _
                       LookAt:=xlPart, _
                       SearchOrder:=xlByRows, _
                       SearchDirection:=xlNext, _
                       MatchCase:=True)

    'Check something has been found before continuing.
    If Not rFound Is Nothing Then

        'Find just keeps looping unless you tell it to stop,
        'so record the first found address.
        sFirstAddress = rFound.Address
        Do
            'Save the reason and start row.
            sReason = rFound.Value
            lStart = rFound.Row

            'Find the next REASON in column G.
            Set rFound = SrchRng.FindNext(rFound)

            If rFound.Address = sFirstAddress Then
                'The first instance has been found again, so use column I to find last row of data.
                lEnd = SrchRng.Offset(, 2).Cells(Rows.Count, 1).End(xlUp).Row
            Else
                lEnd = rFound.Row
            End If

            'Fill in from 2 rows down from Start and 2 rows up from End.
            'This will go wrong if there's not enough space between REASONs.
            With ThisWorkbook.Worksheets("Sheet1")
                .Range(.Cells(lStart + 2, 10), .Cells(lEnd - 2, 10)) = sReason
            End With

        Loop While rFound.Address <> sFirstAddress
    End If

End Sub

Answer 2

There's a few things wrong with this. As you iterate through cel in SrchRng your conditional is checking the value of that cel to contain "REASON". This is not what you want. What you are essentially doing is checking for the "REASON" string and saying all entries below this, until the next reason, should be true for a conditional to populate column J.

Lets, really briefly, run through the logic of a single cell to illustrate why your code was not doing what you wanted: In cell G3, you check to see if it contains the "REASON" string. It does not, so there is no assignment of any value anywhere. The following will do what you want:

Sub AddSus()
Dim SrchRng As Range, cel As Range, reasonString As String
Set SrchRng = Range("g1:g60")
For Each cel In SrchRng
    If InStr(1, cel.Value, "REASON") > 0 Then
        reasonString = cel.Value
    ElseIf cel.Value <> "" Then
        cel.Offset(0, 3).Value = reasonString
  End If
Next cel
End Sub

Minor note but if you are in column G and you want to populate column J, the offset should be .offSet(0,3) .

Answer 3

A Quick and Dirty Solution...

Sub AddSus()

    Dim SrchRng As Range, cel As Range
    Dim reason As String

    Set SrchRng = Range("g1:g60")

    For Each cel In SrchRng

        If InStr(1, cel.Value, "REASON") > 0 Then
            reason = cel.Value
        End If

        If cel.Column = 10 And Len(cel.Offset(,-1)) > 0 Then
            cel.Value = reason
        End If

    Next

End Sub