vba=Loop through each row in the data range.(B2:F10000)

[montecarlo2012]

Hi, I will try to explain in different way.
There are an dynamic array at B2:F10000 to read and a column Z2:Z37 with a series from 1 to 36
Read each number of each row and find how many rows are between the same value
Example
If value 10 is found in the row B4:F4 at D4 then on column AA5 will show the count 4 beside Z5 row
After the value 10 is again in another row in this time is at B12:F12 at C12 so counting from row B4 until B12:F12 row there are 7 rows down, now AA6 will show the value 7
The important point here is to know how many Rows there are between the same value
And it Not about how many cells.
The code should work as follows:
Loop through each row in the data range.(B2:F10000)
For each row, find the value in column Z2:Z37
calculate the difference between the current row and the previous row with the same value
I am looking to count the number of rows between occurrences of a value in column Z, and display the result in column AA for each occurrence of the value at the array
the bad part of the code I am loading now is that work only for 200 rows,
if I upload all the 10000 rows then take one hour running and must of the time at the end give me error
that why I came here guys looking for help Please.
here is the code

Sub Total_games_skips()
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

Range("G2:BB100").ClearContents

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)

Range("J1").value = "AVERAGE"
   Range("K1").value = "DEVIATION"
   Range("N1").value = "SKIP"
Range("M1").value = "OUT"
Dim Dn As Range
For Each Dn In rng
With Application
   
   
    'Dn.Offset(, -3) = Fix(.Average(Dn.Resize(, .CountA(Dn.Resize(, col))))) 'this is colum J or 10 [or -3 from 13]
    Dn.Offset(, -3) = Round((.Average(Dn.Resize(, .CountA(Dn.Resize(, col))))), 1)
   If Dn.Offset(, -3) = Fix(Abs(Dn - .Average(Dn.Resize(, .CountA(Dn.Resize(, col)))))) Then
    Dn.Offset(, -1) = "yes"
    End If
    
    If Dn.Offset(, -2).Value2 = Fix(Abs(Dn - .Average(Dn.Resize(, .CountA(Dn.Resize(, col)))))) Then
    Dn.Offset(, -4) = "yes"
    End If
    
    
    Dn.Offset(, -2) = Fix(Abs(Dn - .Average(Dn.Resize(, .CountA(Dn.Resize(, col)))))) 'column K or -2 from 13
   
  
   
    
End With
Next Dn
End Sub

the dent may be is better
thanks.

 

[DanteAmor]

Hi @montecarlo2012. Thanks for posting on the forum.

Some of the problems of your macro is that in the loops you use functions of the sheet or you are reading or writing in the cells of the sheet, for example:

...
  For Each K In dic.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 dic.Item(K)(1)
      Cells(c, 12 + R) = dic.Item(K)(0)(R, 2)
    Next R
  Next K
...
  For Each Dn In rng
    With Application
      Dn.Offset(, -3) = Round((.Average(Dn.Resize(, .CountA(Dn.Resize(, col))))), 1)
      If Dn.Offset(, -3) = Fix(Abs(Dn - .Average(Dn.Resize(, .CountA(Dn.Resize(, col)))))) Then
        Dn.Offset(, -1) = "yes"
      etc...

----------------
I rebuilt your whole macro.
The new macro works everything in arrays.

In my tests for 10,000+ records the result is immediate.

The output is set from cell G2 (so you have it in your macro).

Try the following code with a small sample to review the results, and then test with all data up to F10000.

Sub Total_games_skips_1()
  Dim dic As Object
  Dim a As Variant, b As Variant
  Dim i&, j&, n&, y&, fil&, col&, ant&
  Dim tot As Double, ave As Double, dev As Double
 
  a = Range("B2:F" & Range("B" & Rows.Count).End(xlUp).Row).Value   'dynamic array of 5 columns ("B2:F")
  Range("G2", Cells(Rows.Count, Columns.Count)).ClearContents
  Set dic = CreateObject("scripting.dictionary")
 
  'Only to know the maximum number of times a value is repeated
  For i = 1 To UBound(a, 1)
    For j = 1 To UBound(a, 2)
      dic(a(i, j)) = dic(a(i, j)) + 1
      If dic(a(i, j)) > n Then n = dic(a(i, j))
    Next
  Next
  ReDim b(1 To dic.Count, 1 To n + 6)  'Output Array
  dic.RemoveAll
 
  'Index each value
  For i = 1 To UBound(a, 1)
    For j = 1 To UBound(a, 2)
      If Not dic.exists(a(i, j)) Then
        y = y + 1
        dic(a(i, j)) = y & "|" & 7 & "|" & i - 1
        b(y, 1) = a(i, j)
        b(y, 7) = i - 1
      Else
        fil = Split(dic(a(i, j)), "|")(0)
        col = Split(dic(a(i, j)), "|")(1)
        ant = Split(dic(a(i, j)), "|")(2)
        col = col + 1
        b(fil, col) = i - (ant + 2)
        dic(a(i, j)) = fil & "|" & col & "|" & i - 1
      End If
    Next
  Next
 
  'Get average, deviation and "yes"
  For i = 1 To dic.Count
    col = Split(dic(b(i, 1)), "|")(1) - 6
    tot = 0
    For j = 7 To col + 6
      tot = tot + b(i, j)
    Next
    ave = (tot / col)                       'Average
    dev = Fix(Abs(b(i, 7) - ave))           'Deviation
    b(i, 4) = Round(ave, 1)
    If b(i, 5) = dev Then b(i, 3) = "yes"
    b(i, 5) = dev
    If b(i, 4) = dev Then b(i, 6) = "yes"
  Next

  'Output of the entire array b
  With Range("G2").Resize(dic.Count, UBound(b, 2))
    .Value = b
    .Sort Range("G2"), xlAscending
  End With
End Sub

--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------

 

[montecarlo2012]

Dante Amor thank you, you are the best, work perfect and quick.

 

[montecarlo2012]

well taking advantage of your kindness, let me ask you, I am trying to do this but for the whole G array

Sub CountZeros()
    Dim rng As Range
    Dim cell As Range
    Dim count As Integer
    
    
    Set rng = Range("M2:AZP2")
    
   
    For Each cell In rng
        If cell.Value = 0 Then
            count = count + 1
        End If
    Next cell
    
    'display the count
    Range("H2").Value = count
End Sub

trying to add to the code how to count zeros this is just an example
just in case you decide to give me that little push. thank you Dante Amor

 

[montecarlo2012]

This of course is counting zeros generated by your code so it is not another thread.

 

[montecarlo2012]

well I put together

Sub tZeros()
    Dim ws As Worksheet
    Dim lastColumn As Long
    Dim count As Long
    Dim i As Long, j As Long, k As Long
    
    
    Set ws = ActiveSheet
    
    
    For k = 2 To 37
        
        lastColumn = ws.Cells(k, ws.Columns.count).End(xlToLeft).Column
        
        
        count = 0
        For i = 13 To lastColumn
            If ws.Cells(k, i).Value = 0 Then
                count = count + 1
            End If
        Next i
        
        
        ws.Cells(k, "H").Value = count
    Next k
End Sub

ok, I don't want to give you hard time I think better insert a new modulo and done, but thank you for reading this.

 

[montecarlo2012]

Awesome job Dante, still I don't understand why you are not MVP jet

 

[DanteAmor]

Awesome job Dante, still I don't understand why you are not MVP jet

Thanks for the compliment.

well taking advantage of your kindness, let me ask you, I am trying to do this but for the whole G array ...
trying to add to the code how to count zeros this is just an example
just in case you decide to give me that little push.

In the following cycles we already do the tour of the entire output array. Just add the following line:

    For j = 7 To col + 6
      tot = tot + b(i, j)
      If b(i, j) = 0 Then b(i, 2) = b(i, 2) + 1
    Next

 

[montecarlo2012]

perfect thank you Dante.

 

[montecarlo2012]

Hello. I have a problem now, every time I update my array I have to open a new workbook in order this code work otherwise give error.
run time error 1004
appliction define or object define error
and highlight this line

thank you.