For Next loop

[Steve]

Hi All,

With the code below:
Dim rng As Range
Dim cell As Range
Dim start_str As Integer
Dim FindText As Range
Dim Length As Integer

On Error Resume Next
Set FindText = Application.InputBox(prompt:= _
"Select Cell with Contents to Find", Type:=8)
If FindText Is Nothing Then
Exit Sub
End If
On Error GoTo 0

Set rng = Selection
Length = Len(FindText)

For Each cell In rng
start_str = InStr(cell.Value, FindText)
If start_str Then
cell.Characters(start_str, Length).Font.Bold = True
cell.Characters(start_str, Length).Font.Color = 192
End If
Next

I have an input box that alolows me to select a cell, which becomes
the "find" criteria to change the font in the selection. Is there a
way to modify the code to allow me to select several cells via the
inputbox, and loop through each cell to do the "find and replace" on
the selection in one swoop?

Thanks!

 

[Per Jessen]

Hi All,

With the code below:
Dim rng As Range
Dim cell As Range
Dim start_str As Integer
Dim FindText As Range
Dim Length As Integer

On Error Resume Next
    Set FindText = Application.InputBox(prompt:= _
            "Select Cell with Contents to Find", Type:=8)
        If FindText Is Nothing Then
            Exit Sub
        End If
On Error GoTo 0

    Set rng = Selection
    Length = Len(FindText)

    For Each cell In rng
        start_str = InStr(cell.Value, FindText)
        If start_str Then
            cell.Characters(start_str, Length).Font.Bold = True
            cell.Characters(start_str, Length).Font.Color =192
        End If
    Next

I have an input box that alolows me to select a cell, which becomes
the "find" criteria to change the font in the selection.  Is there a
way to modify the code to allow me to select several cells via the
inputbox, and loop through each cell to do the "find and replace" on
the selection in one swoop?

Thanks!

Try this:

Dim rng As Range
Dim cell As Range
Dim start_str As Integer
Dim FindTextCells As Range
Dim Length As Integer
Dim FindText As String

Application.Screenupdating = False
On Error Resume Next
Set FindTextCells = Application.InputBox(prompt:= _
"Select Cell with Contents to Find" & vbLf & _
vbLf & "Press CTRL for multi-select", Type:=8)
If FindTextCells Is Nothing Then
Exit Sub
End If
On Error GoTo 0
Set rng = Selection

For Each txt In FindTextCells
FindText = txt
Length = Len(FindText)
For Each cell In rng
start_str = InStr(cell.Value, FindText)
If start_str Then
cell.Characters(start_str, Length).Font.Bold = True
cell.Characters(start_str, Length).Font.Color = 192
End If
Next
Next

Regards,
Per

 

[Steve]

Awesome. Thanks Per!!

Try this:

Dim rng As Range
Dim cell As Range
Dim start_str As Integer
Dim FindTextCells As Range
Dim Length As Integer
Dim FindText As String

Application.Screenupdating = False
On Error Resume Next
    Set FindTextCells = Application.InputBox(prompt:= _
            "Select Cell with Contents to Find" & vbLf & _
            vbLf & "Press CTRL for multi-select", Type:=8)
        If FindTextCells Is Nothing Then
            Exit Sub
        End If
On Error GoTo 0
Set rng = Selection

For Each txt In FindTextCells
    FindText = txt
    Length = Len(FindText)
    For Each cell In rng
        start_str = InStr(cell.Value, FindText)
        If start_str Then
            cell.Characters(start_str, Length).Font.Bold = True
            cell.Characters(start_str, Length).Font.Color =192
        End If
    Next
Next

Regards,
Per- Hide quoted text -

- Show quoted text -