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]

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.

I guess that's on me. I read your initial requirements and didn't quite grasp the implications. But it seems clear enough now that you've explained it again. Try this version of the macro:

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

    Set MyDataLoc = Range("K5")
    XValue = Range("K2").Value
    MaxRange = Range("K3").Value
    Set OutRange = Range("M5")
    
    MyData = Range(MyDataLoc, MyDataLoc.End(xlDown)).Value
    ReDim ar(1 To UBound(MyData), 1 To 2)
    OutRange.Resize(UBound(MyData), 2).ClearContents
    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
            If MyData(j - 1, 1) - MyData(j, 1) > XValue Then Exit For
            TempSum = TempSum + MyData(j, 1)
        Next j
        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 i
    
    OutRange.Resize(ctr, 2) = ar
End Sub

I made a few other tweaks, like using JEC's suggestion for outputting the results, and clearing the output area, but the main change was adding the extra IF using the XValue. I checked the macro using your sample, and it looks like it's doing what you want, but you need to check it too. When I ran the original macro on that sample, I did not get your results, which I can't explain.

It looks like I'm not able to upload the actual spreadsheet,

There is a tool on this forum called XL2BB. See the link in my signature or the reply box. It's easy to download, install, and use. Here's an example:

ME temp.xlsm
	J	K	L	M	N
1
2	ClustPoints_02 -->	0.099
3	ClustMaxRange_02 -->	0.297
4
5	ClustValueStart_02 -->	212.88		83.60667	Group 1 (83.65-83.57)
6		178.18		82.895	Group 2 (82.94-82.85)
7		143.48		82.115	Group 3 (82.2-82.04)
8		114.15		81.53	Group 4 (81.56-81.5)
9		108.79		81.005	Group 5 (81.01-81)
10		104.64		80.39	Group 6 (80.39-80.39)
11		99.8
12		95.71
13		95.13
14		93.88
15		91
16		90.24
17		89.16
18		88.21
19		87.96
20		87.32
21		86.18
22		85.63
23		85.49
24		84.6
25		84.45
26		84.14
27		83.65
28		83.6
29		83.57
30		83.18
31		82.94
32		82.85
33		82.62
34		82.5
35		82.4
36		82.2
37		82.11
38		82.11
39		82.04
40		81.58
41		81.56
42		81.5
43		81.01
44		81.01
45		81
46		80.9
47		80.78
48		80.39
49		80.39
50		80.05
Sheet37

Using this allows the helpers here to copy and paste your data, instead of requiring us to manually retype it. That might be why my results didn't match yours, I could have entered something wrong.

In any event, let me know how this works!