VBisgreat,
This code will create a new worksheet and output the results to this new sheet. It will sort the results by number of appearances so that the most common is on top, 2nd-most common is next and so on. It will then highlight the maximum group size wherever it is in the list so that it can be easily referenced.
Sub tgr()
Dim rngCheck As Range
Dim rngCell As Range
Dim rngArea As Range
Dim rngGroups(2 To 65000) As Range
Dim arrGroups(2 To 65000) As Long
Dim dAvg(2 To 65000) As Double
Dim arrLoc(2 To 65000) As String
Dim lCount As Long
Dim lMax As Long
Dim lCommon As Long
Dim CommonIndex 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 > 1 Then
If lCount > lMax Then lMax = lCount
arrGroups(lCount) = arrGroups(lCount) + 1
'MsgBox "Streak: " & lCount & Chr(10) & "Quantity of streak: " & arrGroups(lCount)
If arrGroups(lCount) > lCommon Then
lCommon = arrGroups(lCount)
CommonIndex = lCount
End If
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
arrLoc(lCount) = arrLoc(lCount) & "," & rngCell.Offset(-lCount).Resize(lCount).Address(0, 0)
End If
lCount = 0
End If
Next rngCell
If lMax > 0 Then
For i = 2 To lMax
If Not rngGroups(i) Is Nothing Then
For Each rngArea In rngGroups(i).Areas
dAvg(i) = dAvg(i) + rngArea.Offset(-1).Cells(1).Value
Next rngArea
dAvg(i) = dAvg(i) / rngGroups(i).Areas.Count
arrLoc(i) = Mid(arrLoc(i), 2)
Else
dAvg(i) = 0
End If
Next i
With Sheets.Add
.Range("A2").Resize(lMax - 1).Value = Application.Transpose(Application.Transpose(Evaluate("Index(Row(2:" & lMax & "),)")))
.Range("B2").Resize(lMax - 1).Value = Application.Transpose(arrGroups)
.Range("C2").Resize(lMax - 1).Value = Application.Transpose(dAvg)
.Range("D2").Resize(lMax - 1).Value = Application.Transpose(arrLoc)
With .Range("A1:D1")
.Value = Array("Group Size", "Appearances", "Positive Average", "Location")
.Font.Bold = True
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Resize(, 3).EntireColumn.AutoFit
End With
.UsedRange.Sort .Range("B1"), xlDescending, Header:=xlYes
.Columns("A").Find(lMax).Resize(, 4).Interior.ColorIndex = 6
End With
End If
Set rngCheck = Nothing
Set rngCell = Nothing
Set rngArea = Nothing
Erase rngGroups
Erase arrGroups
Erase dAvg
Erase arrLoc
End Sub
Bookmarks