25 minutes code, skip report.

[montecarlo2012]

Hello.

Sub FRQ()
Dim rng  As Range, Dn As Range, Rw As Range
Dim n       As Long
Dim Q       As Variant
Dim Omax    As Integer, oSub As Integer

Set rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp)).Resize(, 5)    'dynamic array of 5 columns ("B2:F")
    ReDim Ray(1 To rng.Count, 1 To 2)
   
With CreateObject("scripting.dictionary")
                  .CompareMode = vbTextCompare
                 
                  For Each Rw In rng.Rows
                                    n = n + 1
                                                   For Each Dn In Rw.Columns
                                                  
                                                               If Not .Exists(Dn.Value) Then
                                                                           Ray(1, 1) = n - 1: Ray(1, 2) = n - 1
                                                                           .Add Dn.Value, Array(Ray, 1)
                                                                           Else
                                                                           Q = .Item(Dn.Value)
                                                                           Q(1) = Q(1) + 1
                                                                           oSub = IIf(Q(1) > 2, 1, 2)
                                                                           Q(0)(Q(1), 1) = n
                                                                           Q(0)(Q(1), 2) = n - Q(0)(Q(1) - 1, 1) - oSub
                                                                           Omax = Application.Max(Omax, Q(1))
                                                                           .Item(Dn.Value) = Q
                                                               End If
                                                   Next Dn
                                    Next Rw
                                   
                  Dim K As Variant
                  Dim R As Long
                  Dim c As Long
                  c = 1
                              For Each K In .keys
                                          c = c + 1
                                          Cells(c, 7) = K                                                '' Column G, with the list of numbers you want to report
                                          Cells(c, 12).Font.Bold = True                         'location for the results
                                         
                                                   For R = 1 To .Item(K)(1)
                                                               Cells(c, 12 + R) = .Item(K)(0)(R, 2)
                                                   Next R
                              Next K
                             
                  Range("G2").Resize(.Count, Omax + 5).Sort Range("G2"), xlAscending 'the bin from 1 to end
                  Call RwData(Range("M2").Resize(.Count), Omax) ' this is the skip report starter or column 13
End With
End Sub
Sub RwData(rng As Range, col As Integer)
Dim Dn As Range
For Each Dn In rng
With Application
    Dn.Offset(, -5) = .Max(Dn.Resize(, .CountA(Dn.Resize(, col)))) 'column H or 8 - is minus 5 from 13 or column M
    Dn.Offset(, -3) = .Average(Dn.Resize(, .CountA(Dn.Resize(, col))))  'this is colum J or 10 [or -3 from 13]
    Dn.Offset(, -2) = Dn - .Average(Dn.Resize(, .CountA(Dn.Resize(, col)))) 'column K or -2 from 13
End With
Next Dn
End Sub

The code-speak by itself,
my problem is:
Take 25 minutes to run, wondering if there is another really fast way to do it,
and
of course "I don't know"
My dynamic array is 12000 rows. sheet2("B2:F........)
This code counts the cells between the same value.

 

[offthelip]

USE VARIANT ARRAYS ,
I don't have a lot of time but a quick modification of the first bit of the code as follows:

Dim rng  As Variant 
' make rng a variant array
 Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp)).Resize(, 5)    'dynamic array of 5 columns ("B2:F")
    ReDim Ray(1 To UBound(Rng, 1), 1 To 2)
 
With CreateObject("scripting.dictionary")
                  .CompareMode = vbTextCompare
               
'                  For Each Rw In Rng.Rows
                  For i = 1 To UBound(Rng, 1)
                                    n = n + 1
'                                                   For Each Dn In Rw.Columns
                                                    For j = 1 To UBound(Rng, 2)
                                                               If Not .Exists(Rng(i, j)) Then
                                                                           Ray(1, 1) = n - 1: Ray(1, 2) = n - 1
                                                                           .Add Rng(i, j), Array(Ray, 1)
                                                                           Else
                                                                           Q = .Item(Rng(i, j))
                                                                           Q(1) = Q(1) + 1
                                                                           oSub = IIf(Q(1) > 2, 1, 2)
                                                                           Q(0)(Q(1), 1) = n
                                                                           Q(0)(Q(1), 2) = n - Q(0)(Q(1) - 1, 1) - oSub
                                                                           Omax = Application.Max(Omax, Q(1))
                                                                           .Item(Rng(i, j)) = Q
                                                               End If
                                                   Next Dn
                                    Next Rw

This will speed it up enormously, you need to do something similar with the second half

 

[montecarlo2012]

Offthelip, hello. sorry for the delay, I just get out from my job
thank you for your input.
well, I tried the second part but errors happen.

Sub theofflip()
Dim Dn As Range, Rw As Range
Dim n       As Long
Dim Q As Variant, rng As Variant
Dim Omax    As Integer, oSub As Integer

rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp)).Resize(, 5)    'dynamic array of 5 columns ("B2:F")

    'ReDim Ray(1 To rng.Count, 1 To 2)
    
    ReDim Ray(1 To UBound(rng, 1), 1 To 2)
    
With CreateObject("scripting.dictionary")
                  .CompareMode = vbTextCompare
                  
                 ' For Each Rw In rng.Rows
                 
                 For i = 1 To UBound(rng, 1)
                                    n = n + 1
                                                   'For Each Dn In Rw.Columns
                                                   For j = 1 To UBound(rng, 2)
                                                   
                                                              ' If Not .Exists(Dn.Value) Then
                                                              If Not .exists(rng(i, j)) Then
                                                               
                                                                           Ray(1, 1) = n - 1: Ray(1, 2) = n - 1
                                                                           .Add rng(i, j), Array(Ray, 1)
                                                                           
                                                                         '  .Add Dn.Value, Array(Ray, 1)
                                                                           Else
                                                                           
                                                                           'Q = .Item(Dn.Value)
                                                                           Q = .Item(rng(i, j))
                                                                           Q(1) = Q(1) + 1
                                                                           oSub = IIf(Q(1) > 2, 1, 2)
                                                                           Q(0)(Q(1), 1) = n
                                                                           Q(0)(Q(1), 2) = n - Q(0)(Q(1) - 1, 1) - oSub
                                                                           Omax = Application.Max(Omax, Q(1))
                                                                          ' .Item(Dn.Value) = Q
                                                                          .Item(rng(i, j)) = Q
                                                               End If
                                                               Next j
                                                               Next i
                                                               
'                                                   Next Dn
'                                    Next Rw
                                    
                  Dim K As Variant
                  Dim R As Long
                  Dim c As Long
                  c = 1
                              For Each K In .keys
                                          c = c + 1
                                          Cells(c, 7) = K                                                '' Column G, with the list of numbers you want to report
                                          Cells(c, 12).Font.Bold = True                         'location for the results
                                          
                                                   For R = 1 To .Item(K)(1)
                                                               Cells(c, 12 + R) = .Item(K)(0)(R, 2)
                                                   Next R
                              Next K
                              
                  Range("G2").Resize(.Count, Omax + 5).Sort Range("G2"), xlAscending 'the bin from 1 to end
                  Call RwData(Range("M2").Resize(.Count), Omax) ' this is the skip report starter or column 13
End With
End Sub
'Sub RwData(rng As Range, col As Integer)
Sub RwData(rng As Variant, col As Integer)

'Dim Dn As Range
'For Each Dn In rng
 For j = 1 To UBound(rng, 2)
 
 
With Application
    'Dn.Offset(, -5) = .Max(Dn.Resize(, .CountA(Dn.Resize(, col)))) 'column H or 8 - is minus 5 from 13 or column M
    rng.Offset(, -5) = .Max(rng.Resize(, .CountA(rng.Resize(, col))))
    
    'Dn.Offset(, -3) = .Average(Dn.Resize(, .CountA(Dn.Resize(, col))))  'this is colum J or 10 [or -3 from 13]
    rng.Offset(, -3) = .Average(rng.Resize(, .CountA(rng.Resize(, col))))
    
    'Dn.Offset(, -2) = Dn - .Average(Dn.Resize(, .CountA(Dn.Resize(, col)))) 'column K or -2 from 13
    rng.Offset(, -2) = rng - .Average(rng.Resize(, .CountA(rng.Resize(, col))))
    
End With
'Next Dn
Next j

End Sub

give me debug here

 

[offthelip]

I am not sure about your definition of rng change it to this :

lastrow = .Cells(Rows.Count, "B").End(xlUp).Row
Rng = Range(Cells(2, 2), Cells(lastrow, 6))

This should give you an array equivalent to B2:F & the lastrow in B

 

[montecarlo2012]

Thanks, I just tried to follow the way you think, please don't hesitate to do any changes here.

 

[BSALV]

Can you give a brief description of what you're trying to do here ?