detecting and counting gaps VBA-CodePudding

I have a question regarding finding and detecting gaps per row in VBA excel. The dificult part is gaps that start on Friday and run until Thursday (FTGaps) need to be added up seperately and gaps starting on other days have to be counted seperately.

So for instance in the picture the result from the first row has to be: 1 FTGap and 1 Gap And the second row has to be 1 FTGap.

But if there is a empty cell earlier in the row it has to be counted as a different gap. So for instance the following rows output is 2 gaps and 1 FTGap.

I hope my question is clear. Thanks in advance

What I tried

For Row = 3 To Worksheets("Kalender2").UsedRange.Rows.Count
GapDays = 0
FTGapDays = 0

For col = 2 To 55 'Worksheets("Kalender2").Cells(2, 
Columns.Count).End(xlToLeft).Column
    If Worksheets("Kalender2").Cells(Row, col) = "0" And 
    Worksheets("Kalender2").Cells(2, col).Value = "Friday" Then
        
            FTGapDays = FTGapDays   1
            
        ElseIf Worksheets("Kalender2").Cells(Row, col) = "0" And 
   FTGapDays <> 0 Then
            FTGapDays = FTGapDays   1  'doortellen gap startend op 
  vrijdag
            
        ElseIf Worksheets("Kalender2").Cells(Row, col) = "0" And 
 FTGapDays = 0 Then 'And Worksheets("Kalender2").Cells(2, Col).Value <> 
"Friday"  Then
            GapDays = GapDays   1   'eerste lege cel andere dag dan 
 vrijdag
           
    End If
Next col

If col = 54 Then
    Call EndGap
End If

Call EndGap Next Row '

And then the second Sub Endgap():

If FTGapDays <> 0 Then
If FTGapDays < 7 Then
    If GapDays = 0 Then
        Gaps = Gaps   1
    End If
ElseIf FTGapDays >= 7 And FTGapDays < 14 Then
    FTGaps = FTGaps   1
    If GapDays = 0 Then
        Gaps = Gaps   1
    End If
ElseIf FTGapDays >= 14 And FTGapDays < 21 Then
    FTGaps = FTGaps   2
    If GapDays = 0 Then
        Gaps = Gaps   1
    End If
ElseIf FTGapDays >= 21 And FTGapDays < 28 Then
    FTGaps = FTGaps   3
    LegGaps = LegGaps   1
    If GapDays = 0 Then
        Gaps = Gaps   1
    End If
ElseIf FTGapDays >= 28 And FTGapDays < 35 Then
    FTGaps = FTGaps   4
    LegGaps = LegGaps   1
    If GapDays = 0 Then
        Gaps = Gaps   1
    End If
ElseIf FTGapDays >= 35 And FTGapDay < 42 Then
    FTGaps = FTGaps   5
    LegGaps = LegGaps   1
    If GapDays = 0 Then
        Gaps = Gaps   1
    End If
ElseIf FTGapDays = 42 Then
    FTGaps = FTGaps   6
    LegGaps = LegGaps   2
End If

End If

End Sub

CodePudding user response：

Please, test the next solution. It uses a kind of trick: Dividing a number to 0 in a formula will return an error. So, such a formula is placed two rows down after the last, then using SpecialCells(xlCellTypeFormulas, xlErrors) creates a discontinuous range of the gaps and process it. The processing result is returned two columns to the right of the last column. In the first such a column the 'Gaps' and in the second one 'FTGap'. The code assumes that the row keeping the days name is the second and the zero (0) seen in your pictures are values not string as you tried using in your code:

Sub extractGaps()
  Dim sh As Worksheet, lastR As Long, lastCol As Long, rng As Range, arrCount, arrRows, i As Long
  
  Set sh = ActiveSheet
  lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
  lastCol = sh.cells(2, sh.Columns.count).End(xlToLeft).column
  ReDim arrCount(1 To lastR - 2, 1 To lastCol)
  
  Application.Calculation = xlCalculationManual: Application.ScreenUpdating = False
  For i = 3 To lastR
        arrRows = countGaps(sh.Range("A" & i, sh.cells(i, lastCol)), lastR, lastCol)
        arrCount(i - 2, 1) = arrRows(0): arrCount(i - 2, 2) = arrRows(1)
  Next i
  sh.Range("A" & lastR   2).EntireRow.ClearContents
  sh.cells(3, lastCol   2).Resize(UBound(arrCount), 2).value = arrCount
  Application.Calculation = xlCalculationAutomatic: Application.ScreenUpdating = True
  MsgBox "Ready..."
End Sub
Function countGaps(rngR As Range, lastR As Long, lastCol As Long) As Variant
     Dim sh As Worksheet: Set sh = rngR.Parent
     Dim rngProc As Range, i As Long, A As Range, FTGap As Long, Gap As Long, boolGap As Boolean, bigGaps As Double
     Set rngProc = sh.Range(sh.cells(lastR   2, 1), sh.cells(lastR   2, lastCol)) 'a range where to place a formula returnig errors deviding by 0...
     
      rngProc.Formula = "=1/" & rngR.Address
     On Error Resume Next
      Set rngProc = rngProc.SpecialCells(xlCellTypeFormulas, xlErrors)
     On Error GoTo 0
     If rngProc Is Nothing Then countGaps = Array(0#): Exit Function 'in case of no gaps...
     
     Gap = 0: FTGap = 0
     For Each A In rngProc.Areas
        If A.cells.count < 7 Then
            Gap = Gap   1
        ElseIf A.cells.count = 7 Then
            If sh.cells(2, A.cells(1).column).value = "Friday" Then
                FTGap = FTGap   1
            Else
                Gap = Gap   1
            End If
        Else 'for more than 7 empty cells:
            For i = 1 To A.cells.count
                If sh.cells(2, A.cells(i).column).value = "Friday" Then
                    If boolGap Then Gap = Gap   1: boolGap = False
                    bigGaps = (A.cells.count - i   1) / 7
                    FTGap = FTGap   Int(bigGaps)
                    If A.cells.count - i   1 - Int(bigGaps) * 7 > 0 Then Gap = Gap   1: Exit For
                Else
                    boolGap = True
                End If
            Next i
        End If
     Next A
     countGaps = Array(Gap, FTGap)
End Function

CodePudding user response：

Problem

We have a range (apparently "B3:BC" & UsedRange.Rows.count). The range is preceded by a row (B2:BC2) containing days of the week repeated in consecutively order: Monday, Tuesday, etc.

Cells for each row in the range contain either a 0 or some other value (integer? does not matter much). Consecutive 0's in a row (length > 0) are treated as a gap. We have two types of gaps:

a regular Gap: a range of consecutive 0's of any length > 0;
a Friday-through-to-Thursday-Gap (FtGap): a range of consecutive 0's, that starts on a Friday and ends on Thursday (length = 7).

For each row we want to count the number of Gaps and FtGaps, taking into account the following condition: a range of consecutive 0's that qualifies as a FtGap should not also be counted as a regular Gap.

Solution

To solve this problem, I've used range B3:BC20 for the data. Cells in this range have been populated randomly with either 0's or 1's (but this value could be anything) using =IF(RAND()>0.8,0,1). My row with "days of the week" starts with a "Monday", but this should make no difference.

I've used the following method:

Create two arrays for row days and the data.
Loop through each row array with nested loop through cols to access all cells per row.
On each new 0, increment the total Gap count (GapTrack) by 1. For each new 0, increment a variable (GapTemp) by 1 that tracks the length of the Gap. Reset GapTemp on the next non-0.
For each 0 on a "Friday", start incrementing a variable FtTemp. We keep checking if its value (length) has reached any multiple of 7. When it does, we increment the Ft count (FtTrack) by 1.
On each new non-0, check if FtTemp mod 7 = 0 and GapTemp Mod 7 = 0 and GapTemp > 0. If True, we will have added a regular Gap to our total count of the same length as one or more FtTemps. This violates the condition mentioned above. Remedy this by decrementing GapTrack by 1.
At the end of the row, we wrap GapTrack and FtTrack inside an array, assign it to a new key in a dictionary. At the start of the next row, we reset all our variables, and restart the count.
When the loop is finished, we end up with a dictionary that contains all our counts per row. We write this data away somewhere.

Code as follows with some further notes on what is happening. N.B. I've used "Option Explicit" to force proper declaration of all our variables.

Option Explicit
Sub CountGaps()

Dim wb As Workbook
Dim ws As Worksheet

Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Kalender2")

Dim rngDays As Range, rngData As Range
Dim arrDays As Variant, arrData() As Variant

Set rngDays = ws.Range("Days") 'Named range referencing $B$2:$BC$2 in "Kalender2!"
Set rngData = ws.Range("Data") 'Named range referencing $B$3:$BC$20 in "Kalender2!"

'populate arrays with range values
arrDays = rngDays.Value 'dimensions:    arrDays(1, 1) to arrDays(1, rngDays.Columns.Count)
arrData = rngData.Value 'dimensions:    arrData(1, 1) to arrData(rngData.rows.Count, rngData.Columns.Count)

'declare ints for loop through rows (i) and cols (i) of arrData
Dim i As Integer, j As Integer

'declare booleans to track if we are inside a Gap / FtGap
Dim GapFlag As Boolean, FtFlag As Boolean

'declare ints to track current Gap count (GapTemp), sum Gap count (GapTrack), and same for Ft
Dim GapTemp As Integer, GapTrack As Integer, FtTemp As Integer, FtTrack As Integer

'declare dictionary to store GapTrack and FtTrack for each row
'N.B. in VBA editor (Alt   F11) go to Tools -> References, add "Microsoft Scripting Runtime" for this to work
Dim dict As New Scripting.Dictionary

'declare int (counter) for iteration over range to fill with results
Dim counter As Integer
'declare key for loop through dict
Dim key As Variant

'-----

'start procedure: looping through arrData rows: (arrData(i,1))
For i = LBound(arrData, 1) To UBound(arrData, 1)
    
    'for each new row, reset variables to 0/False
    GapTemp = 0
    GapTrack = 0
    GapFlag = False
    
    FtTemp = 0
    FtTrack = 0
    FtFlag = False
    
    'nested loop through arrData columns: (arrData(i,2))
    For j = LBound(arrData, 2) To UBound(arrData, 2)
        
        If arrData(i, j) = 0 Then
            'cell contains 0: do stuff
            
            If arrDays(1, j) = "Friday" Then
                'Day = "Friday", start checking length Ft gap
                FtFlag = True
            End If
            
            'increment Gap count
            GapTemp = GapTemp   1

            If GapFlag = False Then
            'False: Gap was not yet added to Total Gap count;
            'do this now
                GapTrack = GapTrack   1
                
                'toggle Flag to ensure continuance of 0 range will not be processed anew
                GapFlag = True
                
            End If
            
            If FtFlag Then
                'We are inside a 0 range that had a Friday in the preceding cells
                'increment Ft count
                FtTemp = FtTemp   1
                
                If FtTemp Mod 7 = 0 Then
                    'if True, we will have found a new Ft Gap, add to Total Ft count
                    FtTrack = FtTrack   1
                    
                    'toggle Flag to reset search for new Ft Gap
                    FtFlag = False
                End If
                
            End If
            
        Else
            'cell contains 1: evaluate variables

            If (FtTemp Mod 7 = 0 And GapTemp Mod 7 = 0) And GapTemp > 0 Then
                'if True, then it turns out that our last range STARTED with a "Friday" and continued through to a "Thursday"
                'if so, we only want to add this gap to the Total Ft count, NOT to the Total Gap count
                'N.B. since, in fact, we will already have added this range to the Total Gap count, we need to retract that step
                'Hence: we decrement Total Gap count
                GapTrack = GapTrack - 1
            End If
        
            'since cell contains 1, we need to reset our variables again (except of course the totals)
            GapTemp = 0
            GapFlag = False
            
            FtTemp = 0
            FtFlag = False

        End If
        
    Next j

    'finally, at the end of each row, we assign the Total Gap / Ft counts as an array to a new key (i = row) in our dictionary
    dict.Add i, Array(GapTrack, FtTrack)

Next i

'we have all our data now stored in the dictionary
'example of how we might write this data away in a range:

rngDays.Columns(rngData.Columns.Count).Offset(0, 1) = "Gaps"    'first col to the right of data
rngDays.Columns(rngData.Columns.Count).Offset(0, 2) = "FtGaps"  'second col to the right of data

'set counter for loop through keys
counter = 0
For Each key In dict.Keys
    
    'resize each cell in first col to right of data to fit "Array(GapTrack, FtTrack)" and assign that array to its value ("dict(key)")
    rngData.Columns(rngData.Columns.Count).Offset(counter, 1).Resize(1, 2).Value = dict(key)
    'increment counter for next cell
    counter = counter   1
    
Next key

End Sub

Snippet of result:

Let me know if you experience any difficulties with implemention.