CODEWITHSUNDEEP
excelvbaloops
BobTaske
BobTaske

Reputation: 13

selecting multiple different ranges in a loop VBA

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"

Upvotes: 0

Views: 722

Answers (3)

Zer0Kelvin
Zer0Kelvin

Reputation: 354

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

Upvotes: 1

JohnSUN
JohnSUN

Reputation: 2539

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

Upvotes: 1

Tim Williams
Tim Williams

Reputation: 166196

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

Upvotes: 0

Related Questions