selecting multiple different ranges in a loop VBA

Question

I'm new to VBA and I'm trying to make a macro that searches through column C finds all the cells containing "teston" then finds the cell below it containing "testoff" and highlights all of the cells in between them in the column next to it. there are multiple instances of teston to testoff.

this code works but only highlights the first instance of teston to testoff

    Dim findrow As Long, findrow2 As Long


    On Error GoTo errhandler


    findrow = Range("C:C").Find("teston", Range("C1")).Row
    findrow2 = Range("C:C").Find("testoff", Range("C" & findrow)).Row
    Range("F" & findrow + 1 & ":F" & findrow2 - 1).Select
        With Selection.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 16764159
                .TintAndShade = 0
                .PatternTintAndShade = 0
              End With
errhandler:
    MsgBox "No Cells containing specified text found"

This is what i tried to do to highlight them all but it doesn't highlight anything

    Range("A1").Select
    Selection.End(xlDown).Select
    Dim lastcell As Long
    lastcell = ActiveCell.Row
    
    Dim findrow As Long, findrow2 As Long, I As Long, inext As Long
    
    inext = 1
    
    On Error GoTo errhandler
    
      Do While I < lastcell
              
            findrow = Range("C" & inext & ":" & "C" & lastcell).Find("test1", Range("C1")).Row
            findrow2 = Range("C" & inext & ":" & "C" & lastcell).Find("test2", Range("C" & findrow)).Row
            Range("F" & findrow + 1 & ":F" & findrow2 - 1).Select
                With Selection.Interior
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                        .Color = 16764159
                        .TintAndShade = 0
                        .PatternTintAndShade = 0
                End With
            Range("findrow2").Select
            inext = ActiveCell.Row
            findrow = findrow2
                I = I + 1
       Loop
              
errhandler:
    MsgBox "No Cells containing specified text found"

What range should your macro fill if column C contains several __testons__ and only one __testoff__? — JohnSUN, Sep 23 '20 at 01:57
I didn't notice this line right away - `Range("findrow2").Select`. What it does? More precisely, what do you think it should do? — JohnSUN, Sep 23 '20 at 06:34
What I mean is that whatever the named range "findrow2" is, `inext` always points to this row and does not shift in loop - so you only paint the first `test1/test2` pair. And this named range must be there, otherwise you will go to `errhandler:` Or are you really going there? — JohnSUN, Sep 23 '20 at 08:34
i was trying to grab the cell row of findrow2 by selecting it ` Range("findrow2").Select ` then grabbing cell value and setting that to `inext` so the next loop starts at `inext` and goes down from there — BobTaske, Sep 25 '20 at 04:56
Ah, maybe you wanted to write `inext = Range("C" & findrow2).Row` or simple `inext = findrow2`? — JohnSUN, Sep 25 '20 at 05:03

score 1 · Answer 1 · answered Sep 23 '20 at 02:33

1

Don't look for them separately. Just go through the entire column and they will be found by themselves.

Sub color_between_tests()
Dim tSearch As Range
Dim oCell As Range
Dim bColorOn As Boolean
    Set tSearch = Application.Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("C"))
    bColorOn = False
    For Each oCell In tSearch
        oCell.Offset(0, 3).Interior.Color = 16764159
        Select Case oCell.Text
            Case "teston"
                bColorOn = True
            Case "testoff"
                bColorOn = False
            Case Else
                If Not bColorOn Then oCell.Offset(0, 3).Interior.Pattern = xlNone
        End Select
    Next oCell
End Sub

answered Sep 23 '20 at 02:33

JohnSUN

2,268
2
5
12

Thanks this worked but it took a few min to execute and I'm trying to make it run faster, I'm not sure what my original code looked like it was doing but i was trying to go down from C1 to find the first case at lets say C54 to C86 then start the search "again" but start at C86 to find the next teston, i'm also trying to figure out why my original code didn't work because from my limited knowledge it looks like it should work just fine – BobTaske Sep 23 '20 at 03:41
Using `Application.ScreenUpdating = False` before the loop and `Application.ScreenUpdating = True` before exiting the procedure should solve the long execution problem. To continue searching from a given location, `findrow` must contain `Range("C" & findrow2)` instead of `Range("C1")` (remember to set `findrow2 = 1` before starting the search!) – JohnSUN Sep 23 '20 at 03:51
Thanks i tried 'Range("C" & findrow2)' before but i forgot to set 'findrow2 = 1' before so nothing happend i guess. should i be using 'Application.ScreenUpdating = False' and 'Application.ScreenUpdating = False' all the time for other macros as well to speed them up? – BobTaske Sep 23 '20 at 04:15
i just tried setting it to 1 and replacing C1 with "C" & findrow2 but it only highlights the first case even though i'm having it loop 10 times – BobTaske Sep 23 '20 at 04:23
About `.ScreenUpdating` see [HERE](https://stackoverflow.com/a/12405808/14094617) – JohnSUN Sep 23 '20 at 05:12

score 1 · Answer 2 · answered Sep 23 '20 at 08:21

1

This should improve the speed

Dim oCell As Range
Dim R As Long
Dim Color_On As Boolean

R = Cells(Rows.Count, 3).End(xlUp).Row
Range("F1:F" & R).Interior.Pattern = xlNone
For Each oCell In Range("C1:C" & R)
    Color_On = oCell = "teston" Or Color_On
    If Color_On Then oCell.Offset(0, 3).Interior.Color = 16764159
    Color_On = Color_On And (oCell <> "testoff")
Next oCell

answered Sep 23 '20 at 08:21

Zer0Kelvin

334
2
7

thanks so much this worked fantastically! is there a reason why this way only takes about a second to run while the other ones would take around 5 min? – BobTaske Sep 24 '20 at 22:21
It's a "rigged" code. ; ) Seriously: fewer instructions, fewer comparisons and fewer assignments = faster code. – Zer0Kelvin Sep 25 '20 at 12:44

score 0 · Answer 3 · answered Sep 23 '20 at 02:18

Try this - assumes every teston is followed by a testoff, and there's no nesting of value pairs

Sub Tester()

    Dim rngSrch As Range, ws As Worksheet, allOn As Collection, c As Range, c2 As Range
    
    Set ws = ActiveSheet
    Set rngSrch = ws.Columns("C")
    
    Set allOn = FindAll(rngSrch, "teston") 'first find all the "teston"
    For Each c In allOn
        'for each one find the next "testoff"
        Set c2 = rngSrch.Find("testoff", after:=c, lookat:=xlWhole)
        If Not c2 Is Nothing Then
            If c2.Row > c.Row Then
                ws.Range(c.Offset(1, 3), c2.Offset(-1, 3)).Interior.Color = vbYellow
            Else
                Exit For 'wrapped back up - exit
            End If
        End If
    Next c
    
End Sub

'find all matches in a given range
Public Function FindAll(rng As Range, val As String) As Collection
    Dim rv As New Collection, f As Range, addr As String
    Set f = rng.Find(what:=val, after:=rng.Cells(rng.Cells.Count), _
        LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False)
    If Not f Is Nothing Then addr = f.Address()
    Do Until f Is Nothing
        rv.Add f
        Set f = rng.FindNext(after:=f)
        If f.Address() = addr Then Exit Do
    Loop
    Set FindAll = rv
End Function

i tried this it executed for a min or two but nothing was highlighted after it finished — BobTaske, Sep 23 '20 at 03:42

selecting multiple different ranges in a loop VBA

3 Answers3