VBA code to lookup & extract matching values within a range

Question

I Have list of Store data with their size as below:

+------------+------+
| StoreNo    | Size |
+------------+------+
| A          |   18 |
| B          |   25 |
| C          |   22 |
| D          |   28 |
| E          |   46 |
| F          |   21 |
| G          |   44 |
| H          |   31 |
| I          |   39 |
| J          |   21 |
+------------+------+

Now I want to extract all the store sizes within the range of + 5 and - 5 of a given store. Eg. See below table for the desired output.

Eg Store A's size is 18. so any stores size is within the range of 13 to 23 should be selected. in this case Store C, F & J. of course this should exclude the Store A.

+---------+------+---+---+---+---+
| StoreNo | Size |   |   |   |   |
+---------+------+---+---+---+---+
| A       |   18 | C | F | J |   |
| B       |   25 | C | D | F | J |
| C       |   22 | A | B | F | J |
+---------+------+---+---+---+---+

So far I tried to do this with nested dictionaries & I'm getting nowhere with this.

Dim StoreRange As Range
Dim CheckRange As Range
Dim s As Range
Dim c As Range

Dim i As Integer
Dim j As Integer

Threshold = 5

Set inner = New Scripting.Dictionary
Set outer = New Scripting.Dictionary

Set StoreRange = Range("Stores") ' Range of store to check
Set CheckRange = Range("Check_Range") ' Range of Full Store data

For Each s In StoreRange
    For Each c In CheckRange
        If c.Offset(0, 1) <= (s.Offset(0, 1).Value + Threshold) And c.Offset(0, 1) >= (s.Offset(0, 1).Value - Threshold) Then
            Set inner(s) = New Scripting.Dictionary
            With inner(s)
                .Add c.Value, c.Offset(0, 1).Value
            End With
        End If
    Next c
    outer.Add s.Value, inner(s)
Next s


' rest of the code to populate the data into excel is here

End Sub

please guide me how to solve this.

Answer 1

Not the greatest answer on large datasets, but let me give an example how to use .Evaluate to pull an array of hits directly:

Sub Test()

Dim lr As Long
Dim rng As Range, cl As Range
Dim A As String, B As String
Dim vals1 As Variant, vals2 As Variant

With Sheet1 'Change accordingly
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    Set rng = .Range("A2:A" & lr)
    A = rng.Address
    B = rng.Offset(0, 1).Address
    For Each cl In rng
        vals1 = .Evaluate("TRANSPOSE(IF(ROW(2:" & lr & "),IF((" & B & ">=" & cl.Offset(0, 1) - 5 & ")*(" & B & "<=" & cl.Offset(0, 1) + 5 & ")*(" & A & "<>""" & cl.Value & """)=1," & A & ","" "")))")
        vals2 = Split(Application.Trim(Join(vals1, " ")), " ")
        cl.Offset(0, 2).Resize(1, UBound(vals2) + 1).Value = vals2
    Next cl
End With

End Sub

---

As per your comment, you could try the following:

Sub Test()

Dim lr As Long, x As Long, y As Long
Dim rng As Range, cl As Range
Dim A As String, B As String
Dim vals1 As Variant, vals2 As Variant, vals3 As Variant, vals4 As Variant
Dim arr1 As Object: Set arr1 = CreateObject("System.Collections.ArrayList")
Dim arr2 As Object: Set arr2 = CreateObject("System.Collections.ArrayList")

With Sheet1'Change accordingly
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    Set rng = .Range("A2:A" & lr)
    A = rng.Address
    B = rng.Offset(0, 1).Address
    For Each cl In rng
        vals1 = .Evaluate("TRANSPOSE(IF(ROW(2:" & lr & "),IF((" & B & ">=" & cl.Offset(0, 1) - 5 & ")*(" & B & "<=" & cl.Offset(0, 1) + 5 & ")*(" & A & "<>""" & cl.Value & """)=1," & A & ","""")))")
        vals2 = Split(Application.Trim(Join(vals1, " ")), " ")
        vals3 = .Evaluate("TRANSPOSE(IF(ROW(2:" & lr & "),IF((" & B & ">=" & cl.Offset(0, 1) - 5 & ")*(" & B & "<=" & cl.Offset(0, 1) + 5 & ")*(" & A & "<>""" & cl.Value & """)=1,ABS(" & B & "-" & cl.Offset(0, 1) & "),"""")))")
        vals4 = Split(Application.Trim(Join(vals3, " ")), " ")

        For x = LBound(vals4) To UBound(vals4)
            If x = LBound(vals4) Then
                arr1.Add CStr(vals2(x))
                arr2.Add CDbl(vals4(x))
            Else
                For y = 0 To arr2.Count
                    Debug.Print arr2(y)
                    If arr2(y) > CDbl(vals4(x)) Then
                        arr1.Insert y, CStr(vals2(x))
                        arr2.Insert y, CDbl(vals4(x))
                        Exit For
                    Else
                        arr1.Add CStr(vals2(x))
                        arr2.Add CDbl(vals4(x))
                    End If
                Next y
            End If
        Next x
        cl.Offset(0, 2).Resize(1, UBound(vals2) + 1).Value = arr1.Toarray
        arr1.Clear
        arr2.Clear
    Next cl
End With

End Sub

Answer 2

Think you can just do this with a couple of loops. I did do an array approach but I think overload unless you have a lot of data.

It's not optimal efficiency as there is duplication.

Sub x()

Dim c As Range, r As Range, v() As String, Threshold As Long, i As Long, c1 As Range

ActiveSheet.UsedRange.Offset(, 2).ClearContents

Threshold = 5
Set r = Range("A2", Range("A" & Rows.Count).End(xlUp))

For Each c In r
    For Each c1 In r.Offset(, 1)
        If c1.Offset(, -1).Value <> c.Value Then
            If Abs(c1.Value - c.Offset(, 1).Value) <= Threshold Then
                c.End(xlToRight).Offset(, 1).Value = c1.Offset(, -1).Value
            End If
        End If
    Next c1
Next c

End Sub