Macro to average groups of values that fall within "X" points of each other

[kvcornie]

I have a list of numerical values in a single column that are sorted from largest to smallest.

I need a macro that will loop through this list looking for "groups" of values that are within "x" points of each other AND whose total range is less than "Y" points or a "MaxRange".

The screenshot below is an example of a list and highlights the groups of values that meet both of these criteria. i.e. In the first group 74 is < 3 points from 72 and 72 is < 3 points from 70, AND the total range of 74-70 < 6 points.

The "Output Range" (C6-C8) is my desired result from the macro.

Thank you for any help!

 

[Eric W]

Welcome to the MrExcel forum!

Try:

Sub FindGroups()
Dim MyDataLoc As Range, XValue As Double, MaxRange As Double, OutRange As Range
Dim MyData As Variant, MyDic As Object, ctr As Long, i As Long, j As Long, TempSum As Double

    Set MyDataLoc = Range("A2")
    XValue = Range("D1").Value
    MaxRange = Range("D2").Value
    Set OutRange = Range("C6")
    
    MyData = Range(MyDataLoc, MyDataLoc.End(xlDown)).Value
    Set MyDic = CreateObject("Scripting.Dictionary")
    ctr = 0
    
    For i = 1 To UBound(MyData)
        TempSum = MyData(i, 1)
        For j = i + 1 To UBound(MyData)
            If MyData(j, 1) < MyData(i, 1) - MaxRange Then Exit For
            TempSum = TempSum + MyData(j, 1)
        Next j
        j = j - 1
        If j > i Then
           ctr = ctr + 1
           MyDic(TempSum / (j - i + 1)) = "Group " & ctr & " (" & MyData(i, 1) & "-" & MyData(j, 1) & ")"
           i = j + 1
        End If
    Next i
    
    OutRange.Resize(MyDic.Count) = WorksheetFunction.Transpose(MyDic.keys)
    OutRange.Resize(MyDic.Count).Offset(, 1) = WorksheetFunction.Transpose(MyDic.items)
End Sub

I noticed that 55 and 60 are not within 3 points of each other, so I assumed that you meant within 3 points of the average. If so, the MaxRange variable should be sufficient to check for that.

 

[JEC]

The last 2 lines of code could be written like this :

OutRange.Resize(MyDic.Count, 2) = Application.Transpose(Array(MyDic.keys, MyDic.items))

 

[Eric W]

The last 2 lines of code could be written like this :

OutRange.Resize(MyDic.Count, 2) = Application.Transpose(Array(MyDic.keys, MyDic.items))

Thanks! I knew there was a way, but apparently my brain is full, since I never can remember how to do it!

 

[JEC]

No problem. Nice solution though!

With a normal array it will be even easier (copied your code)

Sub jec()
 MyData = Range("A2", Range("A2").End(xlDown))
 ReDim ar(1 To UBound(MyData), 1 To 2)
  
 For i = 1 To UBound(MyData)
    TempSum = MyData(i, 1)
    For j = i + 1 To UBound(MyData)
       If MyData(j, 1) < MyData(i, 1) - [D2] Then Exit For
       TempSum = TempSum + MyData(j, 1)
    Next
    j = j - 1
    If j > i Then
       ctr = ctr + 1
       ar(ctr, 1) = TempSum / (j - i + 1)
       ar(ctr, 2) = "Group " & ctr & " (" & MyData(i, 1) & "-" & MyData(j, 1) & ")"
       i = j + 1
    End If
 Next
 Range("C10").Resize(ctr, 2) = ar
End Sub

 

[kvcornie]

Welcome to the MrExcel forum!

Thank you so much, I've been banging my head against a wall for hours on this...it is a perfect plug n' play solution!

 

[Eric W]

Glad we could help! Thanks for the update!

 

[kvcornie]

Welcome to the MrExcel forum!

Try:

Sub FindGroups()
Dim MyDataLoc As Range, XValue As Double, MaxRange As Double, OutRange As Range
Dim MyData As Variant, MyDic As Object, ctr As Long, i As Long, j As Long, TempSum As Double

    Set MyDataLoc = Range("A2")
    XValue = Range("D1").Value
    MaxRange = Range("D2").Value
    Set OutRange = Range("C6")
   
    MyData = Range(MyDataLoc, MyDataLoc.End(xlDown)).Value
    Set MyDic = CreateObject("Scripting.Dictionary")
    ctr = 0
   
    For i = 1 To UBound(MyData)
        TempSum = MyData(i, 1)
        For j = i + 1 To UBound(MyData)
            If MyData(j, 1) < MyData(i, 1) - MaxRange Then Exit For
            TempSum = TempSum + MyData(j, 1)
        Next j
        j = j - 1
        If j > i Then
           ctr = ctr + 1
           MyDic(TempSum / (j - i + 1)) = "Group " & ctr & " (" & MyData(i, 1) & "-" & MyData(j, 1) & ")"
           i = j + 1
        End If
    Next i
   
    OutRange.Resize(MyDic.Count) = WorksheetFunction.Transpose(MyDic.keys)
    OutRange.Resize(MyDic.Count).Offset(, 1) = WorksheetFunction.Transpose(MyDic.items)
End Sub

I noticed that 55 and 60 are not within 3 points of each other, so I assumed that you meant within 3 points of the average. If so, the MaxRange variable should be sufficient to check for that.

I did forget one thing if you have another minute. How could I modify this to determine a minimum number of values be in a grouping? i.e. this will return any 2 value that meet the criteria, I'd like to have a minimum of 3 for example?

Thanks again!

 

[Eric W]

Easy enough.

Change this line:

If j > i Then

to

If j > i + 1 Then

That will allow groups of 3 and up. Change the 1 to a 2, and it will allow groups of 4 and up, etc.

 

[kvcornie]

Welcome to the MrExcel forum!

Try:

Sub FindGroups()
Dim MyDataLoc As Range, XValue As Double, MaxRange As Double, OutRange As Range
Dim MyData As Variant, MyDic As Object, ctr As Long, i As Long, j As Long, TempSum As Double

    Set MyDataLoc = Range("A2")
    XValue = Range("D1").Value
    MaxRange = Range("D2").Value
    Set OutRange = Range("C6")
   
    MyData = Range(MyDataLoc, MyDataLoc.End(xlDown)).Value
    Set MyDic = CreateObject("Scripting.Dictionary")
    ctr = 0
   
    For i = 1 To UBound(MyData)
        TempSum = MyData(i, 1)
        For j = i + 1 To UBound(MyData)
            If MyData(j, 1) < MyData(i, 1) - MaxRange Then Exit For
            TempSum = TempSum + MyData(j, 1)
        Next j
        j = j - 1
        If j > i Then
           ctr = ctr + 1
           MyDic(TempSum / (j - i + 1)) = "Group " & ctr & " (" & MyData(i, 1) & "-" & MyData(j, 1) & ")"
           i = j + 1
        End If
    Next i
   
    OutRange.Resize(MyDic.Count) = WorksheetFunction.Transpose(MyDic.keys)
    OutRange.Resize(MyDic.Count).Offset(, 1) = WorksheetFunction.Transpose(MyDic.items)
End Sub

I noticed that 55 and 60 are not within 3 points of each other, so I assumed that you meant within 3 points of the average. If so, the MaxRange variable should be sufficient to check for that.

Eric,

After using this code, I found an issue where it appeared the MaxRange was being used to evaluate first and then digging further I found that the "XValue" was not being used in the code, only the variable was declared. I tried to fix it by replacing MaxRange w/ XValue in the code, and it is now pulling some of the correct groups of data that are within the XValue from the next value in the list, but it is also missing some of the groups and of course I don't have MaxRange incorporated.

"live note"...In the middle of writing this I just took another look at your comment at the end of your original post about using the Average and MaxRange being sufficient in that case. I didn't understand the implication when I first read it...I guess now I do. But I still don't know how to incorporate the fix and my explanation below should clarify my intent.

Here is the example of the code with the substitution I tried:

If MyData(j, 1) < MyData(i, 1) - XValue Then Exit For

It looks like I'm not able to upload the actual spreadsheet, so I've taken a snapshot with my RangeNames (in Red) as well as a couple of examples of things not working (per my intent) with the original code.

Below are the RangeNames I used in your code.

Set MyDataLoc = Range("ClustValueStart_02")
XValue = Range("ClustPoints_02").Value
MaxRange = Range("ClustMaxRange_02").Value

Again, your help is very much appreciated!

Kurt