VBisgreat,
Updated code:
Sub tgr()
Dim rngCheck As Range
Dim rngCell As Range
Dim rngArea As Range
Dim arrGroups(1 To 65000) As Long
Dim rngGroups(1 To 65000) As Range
Dim dAvg(1 To 2) As Double
Dim lCount As Long
Dim lMax As Long
Dim lCommon As Long
Dim i As Long
Set rngCheck = Intersect(ActiveSheet.UsedRange, Columns("C"))
Set rngCheck = rngCheck.Resize(rngCheck.Rows.Count + 1)
For Each rngCell In rngCheck.Cells
If rngCell.Value < 0 Then
lCount = lCount + 1
Else
If lCount > 0 Then
If lCount > lMax Then lMax = lCount
arrGroups(lCount) = arrGroups(lCount) + 1
If arrGroups(lCount) > lCommon Then lCommon = lCount
Select Case (rngGroups(lCount) Is Nothing)
Case True: Set rngGroups(lCount) = rngCell.Offset(-lCount).Resize(lCount)
Case Else: Set rngGroups(lCount) = Union(rngGroups(lCount), rngCell.Offset(-lCount).Resize(lCount))
End Select
lCount = 0
End If
End If
Next rngCell
If lMax > 0 Then
For Each rngArea In rngGroups(lCommon).Areas
dAvg(1) = dAvg(1) + rngArea.Offset(-1).Cells(1).Value
Next rngArea
dAvg(1) = dAvg(1) / rngGroups(lCommon).Areas.Count
For Each rngArea In rngGroups(lMax).Areas
dAvg(2) = dAvg(2) + rngArea.Offset(-1).Cells(1).Value
Next rngArea
dAvg(2) = dAvg(2) / rngGroups(lMax).Areas.Count
MsgBox "Most common group size: " & lCommon & Chr(10) & _
"Appearances: " & arrGroups(lCommon) & Chr(10) & _
"Locations: " & rngGroups(lCommon).Address(0, 0) & Chr(10) & _
"Positive Average: " & dAvg(1) & Chr(10) & _
Chr(10) & _
"Maximum group size:" & lMax & Chr(10) & _
"Appearances: " & arrGroups(lMax) & Chr(10) & _
"Location(s): " & rngGroups(lMax).Address(0, 0) & Chr(10) & _
"Positive Average: " & dAvg(2)
End If
Set rngCheck = Nothing
Set rngCell = Nothing
Set rngArea = Nothing
Erase arrGroups
Erase dAvg
End Sub
Bookmarks