Need help find longest group of numbers

**VBisgreat** · 03-18-2013, 05:15 PM

I have a column of numbers in col C, the numbers vary from -2.00 to +2.00. I’d like a macro that will help find all the group of next-to-each-other negative numbers and compare them and let me know which one is the longest.
EX:
-0.25
-0.72
-0.43
0.05
0.62
-0.05
-0.29
-0.06
-0.34
0.46
1.52
0.96
-0.88
0.55
The answer is 4 because it has four numbers next to each other less than zero.

**tigeravatar** · 03-18-2013, 05:29 PM

VBisgreat,

One way...

Sub tgr()
    
    Dim rngCell As Range
    Dim lCount As Long
    Dim lMax As Long
    
    For Each rngCell In Intersect(ActiveSheet.UsedRange, Columns("C")).Cells
        If rngCell.Value < 0 Then lCount = lCount + 1 Else lCount = 0
        lMax = WorksheetFunction.Max(lMax, lCount)
    Next rngCell
    
    MsgBox lMax
    
End Sub

**VBisgreat** · 03-19-2013, 07:52 AM

Is there a way to tell where the on the list that group occurred? Can you help modify it so that this time instead of finding the longest it will find the one appear most frequent?
ex:
-0.25
-0.72
-0.43
0.05
0.62
-0.05
-0.29
-0.06
0.46
1.52
0.96
-0.88
0.55

the answer is 3 because the three group appearred twice.

Thank you,
VB

**shg** · 03-18-2013, 05:36 PM

How about just a formula?

=MAX(FREQUENCY(IF(A1:A14<0, ROW(A1:A14)), IF(A1:A14>=0, ROW(A1:A14))))

The formula MUST be confirmed with Ctrl+Shift+Enter

**VBisgreat** · 03-19-2013, 07:48 AM

The fomular doesn't work because the data is in col C. Thanks though!

**shg** · 03-19-2013, 11:35 AM

Originally Posted by VBisgreat

The fomular doesn't work because the data is in col C. Thanks though!

That's quite an obstacle to overcome--good luck.

**VBisgreat** · 03-18-2013, 05:42 PM

Is there a way to tell where longest occurred on the list?

**VBisgreat** · 03-18-2013, 05:57 PM

Similarly, I want to know which group happen most often. In this case I want the answer to be 3 because the 3-next-to-each-other negative group appeared most often (twice). Thank you so much!!!

Ex:
-0.25
-0.72
-0.43
0.05
0.62
-0.05
-0.29
-0.06
0.46
1.52
0.96
-0.88
-452
0.55
1.00
1.87
-0.05
-0.29
-0.06
-0.66
1.34

**tigeravatar** · 03-19-2013, 11:52 AM

VBisgreat,

Perhaps...

Sub tgr()
    
    Dim rngCheck As Range
    Dim rngCell As Range
    Dim arrGroups(1 To 65000) As Long
    Dim rngGroups(1 To 65000) As Range
    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
                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 i = 1 To lMax
            If arrGroups(i) > lCommon Then lCommon = i
        Next i
        MsgBox "Most common group size is [" & lCommon & "] appearing " & arrGroups(lCommon) & " time(s) and in location(s):" & Chr(10) & _
               rngGroups(lCommon).Address(0, 0) & Chr(10) & _
               Chr(10) & _
               "Maximum group size is [" & lMax & "] appearing " & arrGroups(lMax) & " time(s) and in location(s):" & Chr(10) & _
               rngGroups(lMax).Address(0, 0)
    End If
    
    Set rngCheck = Nothing
    Set rngCell = Nothing
    Erase arrGroups
    
End Sub

**VBisgreat** · 03-21-2013, 09:33 AM

Can you add this computation in there too?

Ex:
0.62
-0.05
-0.29
-0.06
0.46
1.52
0.96
-0.34
-0.88
0.29
-0.25
-0.72
-0.43
0.05
The most common group is 3 and the average of the positive numbers one place above them is (0.62+0.29)/2=0.455

Do the same thing for maximum group. Find the average of the positive numbers one place above it.

**tigeravatar** · 03-21-2013, 12:17 PM

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

**VBisgreat** · 03-20-2013, 10:57 AM

Thank you all.

**VBisgreat** · 03-21-2013, 02:47 PM

thank you very much!

**VBisgreat** · 03-21-2013, 03:03 PM

I tried running the data using the previous code and this code, the previous one came out for the common group 5 appeared 10 times, but this code shown common group as 4 appeared 8 time. The max groupd is good.

**tigeravatar** · 03-21-2013, 03:44 PM

VBisgreat,

I found the bug and here is the updated code. With that dataset, the most common streak is actually 1 with 88 occurrences. Would you rather that streaks of 1 be ignored? The second most common is streaks of 2 with 42 occurrences. This code will include streaks of 1.

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 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 > 0 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
                lCount = 0
            End If
        End If
    Next rngCell
    
    If lMax > 0 Then
        For Each rngArea In rngGroups(CommonIndex).Areas
            dAvg(1) = dAvg(1) + rngArea.Offset(-1).Cells(1).Value
        Next rngArea
        dAvg(1) = dAvg(1) / rngGroups(CommonIndex).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: " & CommonIndex & Chr(10) & _
               "Appearances: " & arrGroups(CommonIndex) & Chr(10) & _
               "Locations: " & rngGroups(CommonIndex).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

**VBisgreat** · 03-21-2013, 03:58 PM

ignore 1 streak please. Thanks.

**tigeravatar** · 03-21-2013, 04:00 PM

This code will ignore streaks of 1:

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 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
            End If
            lCount = 0
        End If
    Next rngCell
    
    If lMax > 0 Then
        For Each rngArea In rngGroups(CommonIndex).Areas
            dAvg(1) = dAvg(1) + rngArea.Offset(-1).Cells(1).Value
        Next rngArea
        dAvg(1) = dAvg(1) / rngGroups(CommonIndex).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: " & CommonIndex & Chr(10) & _
               "Appearances: " & arrGroups(CommonIndex) & Chr(10) & _
               "Locations: " & rngGroups(CommonIndex).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

**VBisgreat** · 03-21-2013, 04:07 PM

Can have them list from max group, most common, second common...ect? just wondering

or just list them out max streak, second, third, ect... and I can look at it and determine the most common streak...

**tigeravatar** · 03-21-2013, 04:42 PM

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

**VBisgreat** · 03-21-2013, 05:00 PM

Can you put it in a pop up window, I really like the pop-up window. Very convenience. Thanks.

**tigeravatar** · 03-21-2013, 05:04 PM

The information won't all fit in a msgbox (popup window).

**VBisgreat** · 03-21-2013, 05:06 PM

error at: dAvg(i) = dAvg(i) + rngArea.Offset(-1).Cells(1).Value

**tigeravatar** · 03-21-2013, 05:14 PM

VBisgreat,

I am able to run the code with no issues and it performs as expected. Attached is an example workbook that contains the macro. When I run it, I get the results sheet successfully.

**tigeravatar** · 03-21-2013, 05:17 PM

Also, make sure you have a header cell so that actual data starts below row 1.

**tigeravatar** · 03-21-2013, 05:16 PM

Ah, I was able to replicate the error. Update that line of code to the following:

dAvg(i) = dAvg(i) + Val(rngArea.Offset(-1).Cells(1).Value)

**VBisgreat** · 03-21-2013, 05:27 PM

since you have it in another worksheet, can you include the 1 streak too? many thanks.

**tigeravatar** · 03-21-2013, 05:52 PM

Updated code:

Sub tgr()
    
    Dim rngCheck As Range
    Dim rngCell As Range
    Dim rngArea As Range
    Dim rngGroups(1 To 65000) As Range
    Dim arrGroups(1 To 65000) As Long
    Dim dAvg(1 To 65000) As Double
    Dim arrLoc(1 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 > 0 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 = 1 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

**tigeravatar** · 03-21-2013, 05:51 PM

Just change this line:

If lCount > 1 Then

So that it is > 0 instead of > 1
That will include the 1 streaks.

oh wait, there are some other modifications too, just a sec

**VBisgreat** · 03-21-2013, 06:48 PM

It's still ignoring the 1 streak.

**tigeravatar** · 03-21-2013, 06:54 PM

That's what I get for not testing before posting /sigh
This one works

Sub tgr()
    
    Dim rngCheck As Range
    Dim rngCell As Range
    Dim rngArea As Range
    Dim rngGroups(1 To 65000) As Range
    Dim arrGroups(1 To 65000) As Long
    Dim dAvg(1 To 65000) As Double
    Dim arrLoc(1 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 > 0 Then
                If lCount > lMax Then lMax = lCount
                arrGroups(lCount) = arrGroups(lCount) + 1
                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 = 1 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).Value = Application.Transpose(Application.Transpose(Evaluate("Index(Row(1:" & lMax & "),)")))
            .Range("B2").Resize(lMax).Value = Application.Transpose(arrGroups)
            .Range("C2").Resize(lMax).Value = Application.Transpose(dAvg)
            .Range("D2").Resize(lMax).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

**VBisgreat** · 03-21-2013, 07:00 PM

I ran the two code and compared them but the answer from with and without 1 streak don't match up.
size appear
1 88
2 42
3 15
4 9
5 9
6 4
7 2
8 1

Size Appearances
2 88
3 42
4 15
5 9
6 9
7 4
8 2

**tigeravatar** · 03-21-2013, 07:03 PM

The first one is correct, we already know this because I stated earlier that there are 88 1-streaks and 42 2-streaks
The second size/appearances you listed are from the incorrect code that was "ignoring" 1-streaks. It wasn't ignoring them, but it wasn't outputting the display properly which is what I fixed in the most recent code.

**VBisgreat** · 03-21-2013, 07:07 PM

Thank you very much!!!
VBisgreat!!

**VBisgreat** · 03-21-2013, 07:40 PM

keep getting error here sometimes

dAvg(i) = dAvg(i) + rngArea.Offset(-1).Cells(1).Value

**VBisgreat** · 03-21-2013, 08:12 PM

nevermind. Thanks!!

**VBisgreat** · 03-22-2013, 01:40 PM

tigeravatar,

Is there a way you can help me put the output (group size, appearances, ect..) on the same sheet instead of adding another sheet then put it there? it will help make it easier for me. Please put it starting on cell J25.

Thanks sincerely,
VBisgreat

**tigeravatar** · 03-22-2013, 03:52 PM

Updated code:

Sub tgr()
    
    Dim rngCheck As Range
    Dim rngCell As Range
    Dim rngArea As Range
    Dim rngGroups(1 To 65000) As Range
    Dim arrGroups(1 To 65000) As Long
    Dim dAvg(1 To 65000) As Double
    Dim arrLoc(1 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 > 0 Then
                If lCount > lMax Then lMax = lCount
                arrGroups(lCount) = arrGroups(lCount) + 1
                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 = 1 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
        
        Range("J26:M" & Rows.Count).ClearContents
        Range("J26").Resize(lMax).Value = Application.Transpose(Application.Transpose(Evaluate("Index(Row(1:" & lMax & "),)")))
        Range("K26").Resize(lMax).Value = Application.Transpose(arrGroups)
        Range("L26").Resize(lMax).Value = Application.Transpose(dAvg)
        Range("M26").Resize(lMax).Value = Application.Transpose(arrLoc)
        With Range("J25:M25")
            .Value = Array("Group Size", "Appearances", "Positive Average", "Location")
            .Font.Bold = True
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            '.Resize(, 3).EntireColumn.AutoFit
        End With
        Range("J25").Resize(lMax + 1, 4).Sort Range("K25"), xlDescending, Header:=xlYes
        Range("J25:J" & Rows.Count).Find(lMax).Resize(, 4).Interior.ColorIndex = 6
    End If
    
    Set rngCheck = Nothing
    Set rngCell = Nothing
    Set rngArea = Nothing
    Erase rngGroups
    Erase arrGroups
    Erase dAvg
    Erase arrLoc
    
End Sub

Need help find longest group of numbers

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Re: Need help find longest group of numbers

Thread Information

Users Browsing this Thread

Bookmarks

Bookmarks

Posting Permissions