Home > Back-end >  VBA to check if multiple values fall within multiple ranges
VBA to check if multiple values fall within multiple ranges

Time:06-11

I have a list of about 2000 values in column A in Excel, and then a list of the start and end of value ranges in the next two columns. The range values don't correspond to the values in the first column. I want to check, for every value in column A, whether the value falls within ANY of the ranges listed in columns B and C.

Link to table example

So for example, in the image below, see whether A2 falls within B2-C2, B3-C3, OR B4-C4. Then the same again for A3 and A4. For each of these I want true/false to be entered in column D. The true/false value would correspond to the values in column A.

I've been trying to do this in VBA but I'm not totally confident with getting it to search the ranges. Current code is below.

Sub CheckRg()
Dim wk As Worksheet, frow As Long, i As Long

Set wk = Sheet1
frow = wk.Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To frow
    If wk.Range("A" & i).Value >= wk.Range("B:B").Value And wk.Range("A" & i).Value <= wk.Range("C:C").Value Then
    wk.Range("D" & i).Value = "TRUE"
    Else
        wk.Range("D" & i).Value = "FALSE"
    End If
Next i

End Sub

CodePudding user response:

This formula should do the trick without VBA:

=COUNTIFS($B:$B,"<="&A2,$C:$C,">="&A2)<>0

You can use it in your code like this:

Sub CheckRg()
    
    Dim wk As Worksheet, frow As Long, i As Long
    
    Set wk = Sheet1
    frow = wk.Range("A" & Rows.Count).End(xlUp).Row
    
    For i = 2 To frow
        With Excel.WorksheetFunction
            wk.Range("D" & i).Value = .CountIfs(wk.Range("B:B"), Evaluate("""<=""" & "&A" & i), wk.Range("C:C"), Evaluate(""">=""" & "&A" & i)) <> 0
        End With
    Next i

End Sub

CodePudding user response:

An Inefficient Double Loop

  • A better way to go is presented in the solution by Evil Blue Monkey.
  • You need to check each cell in column A against each cell pair of columns B and C which requires a second loop that slows down the operation when thousands of rows are expected.
  • Here's an example of how you could go about that.
Sub CheckRg()
    
    Dim ws As Worksheet: Set ws = Sheet1
    Dim lRow As Long: lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

    Application.ScreenUpdating = False
    
    Dim i As Long
    Dim j As Long
    Dim MatchFound As Boolean
    
    For i = 2 To lRow
        For j = 2 To lRow
            If ws.Range("A" & i).Value >= ws.Range("B" & j).Value _
                    And ws.Range("A" & i).Value <= ws.Range("C" & j).Value Then
                MatchFound = True
                Exit For
            End If
        Next j
        If MatchFound Then
            ws.Range("D" & i).Value = True
            MatchFound = False
        Else
            ws.Range("D" & i).Value = False
        End If
    Next i

    Application.ScreenUpdating = True

    MsgBox "Range checked.", vbInformation

End Sub
  • Related