Loop through ID's and keeps track of whether they pass/fail

Question

I have:

Column A: (IDs)

A
A
A
C
C
Z

Column B: (Values)

  3 
  2 
-6 
-12 
  6 
 2 

I'm trying to create a macro that fills all unique ID's into column C, and counts whether they pass/fail in column D. A pass would be having an associated value in column B between -5 and 5.

Column C/D would look like:

C	D
A	2
C	0
Z	1

If anyone can start me off or link a similar example id appreciate.

Answer 1

You can do it using formulas. But if you like/want VBA, please try the next piece of code. It uses arrays and a dictionary. Working only in memory, it should be very fast, even for large ranges:

Sub CountPassed()
   Dim dict As Object, sh As Worksheet, lastR As Long
   Dim arr, arrFin, i As Long
   
   Set sh = ActiveSheet
   lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
   arr = sh.Range("A2:B" & lastR).value 'place the range in an array for faster iteration
   
   Set dict = CreateObject("Scripting.Dictionary")
   For i = 1 To UBound(arr) 'extract unique keys and their item value according to the rule:
        dict(arr(i, 1)) = dict(arr(i, 1)) + IIf(arr(i, 2) >= -5 And arr(i, 2) <= 5, 1, 0)
   Next i
   'create the necessary final array:
   ReDim arrFin(1 To dict.count, 1 To 2)
   For i = 0 To dict.count - 1
        arrFin(i + 1, 1) = dict.Keys()(i)
        arrFin(i + 1, 2) = dict.items()(i)
   Next i
   'drop the final array at once
   sh.Range("C2").Resize(UBound(arrFin), 2).value = arrFin
End Sub

Answer 2

Count Unique With Limits

• Adjust the values in the constants section.

Option Explicit

Sub CountUniqueWithLimits()
    
    Const sName As String = "Sheet1"
    Const sFirstCellAddress As String = "A1"
    
    Const dName As String = "Sheet1"
    Const dFirstCellAddress As String = "C1"
    
    Const lLimit As String = ">=-5"
    Const uLimit As String = "<=5"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range
    Dim rCount As Long
    With sws.Range(sFirstCellAddress)
        Dim lCell As Range: Set lCell = .Resize(sws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Sub
        rCount = lCell.Row - .Row + 1
        Set srg = .Resize(rCount, 2)
    End With
    
    Dim Data As Variant: Data = srg.Value
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim Key As Variant
    Dim nkey As Variant
    Dim r As Long
    
    For r = 1 To rCount
        Key = Data(r, 1)
        If Not IsError(Key) Then
            If Len(Key) > 0 Then
                If Not dict.Exists(Key) Then
                    dict(Key) = 0
                End If
                nkey = Data(r, 2)
                If IsNumeric(nkey) Then
                    If Len(nkey) > 0 Then
                        If Evaluate(nkey & lLimit) Then
                            If Evaluate(nkey & uLimit) Then
                                dict(Key) = dict(Key) + 1
                            End If
                        End If
                    End If
                End If
            End If
        End If
    Next r
    rCount = dict.Count
    If rCount = 0 Then Exit Sub
    
    ReDim Data(1 To rCount, 1 To 2)
    r = 0
    
    For Each Key In dict.Keys
        r = r + 1
        Data(r, 1) = Key
        Data(r, 2) = dict(Key)
    Next Key
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    With dws.Range(dFirstCellAddress).Resize(, 2)
        .Resize(rCount).Value = Data
        .Resize(dws.Rows.Count - .Row - rCount + 1).Offset(rCount).ClearContents
    End With
    
    MsgBox "Unique values with limits counted.", vbInformation
    
End Sub

Answer 3

Well, it may happen you are not familiar of writing VBA Codes, then you may try any of the options using Excel Formula (Formulas Shown Below Are Exclusively For Excel 2021 & O365 Users)

=CHOOSE({1,2},UNIQUE(ID),COUNTIFS(ID,UNIQUE(ID),Values,">=-5",Values,"<=5"))

In the above formula, we are combining two arrays within a CHOOSE Function.

• The first array contains the unique values in the database

UNIQUE(ID)

Where ID refers to the range =$A$3:$A$8, created using the Define Name Manager.

• The second array is essentially the COUNTIFS Function,

COUNTIFS(ID,UNIQUE(ID),Values,">=-5",Values,"<=5")

Where Values refers to the range =$B$3:$B$8, created using the Define Name Manager.

The CHOOSE function combines both the arrays into a single array, which produces as a two-column table as shown in the image below.

Note that we can also use the LET function to elegantly perform, by defining a variable, U to hold the unique values,

• Formula can also be used in cell C3

=LET(U,UNIQUE(ID),CHOOSE({1,2},U,COUNTIFS(ID,U,Values,">=-5",Values,"<=5")))

You may see that this version of the formula calls the UNIQUE function once only, storing the result in U, which is used twice!