detecting and counting gaps VBA - excel

Question

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

Answer 1

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
If sh.Range("A" & lastR).HasFormula Then
If left(sh.Range("A" & lastR).Formula, 3) = "=1/" Then
sh.rows(lastR).EntireRow.ClearContents
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
End If
End If
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
Dim boolGap As Boolean, bigGaps As Double, mtchFr
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.cells.count = rngR.cells.count Then
If IsNumeric(rngProc.cells(1)) Then countGaps = Array(0, 0): Exit Function
End If
If rngProc Is Nothing Then countGaps = Array(0, 0): Exit Function 'in case of no gaps...
Gap = 0: FTGap = 0: Debug.Print rngProc.Areas.count
For Each A In rngProc.Areas
Debug.Print sh.Range(sh.cells(2, A.cells(1).column), sh.cells(2, A.cells(A.Columns.count).column)).Address: 'Stop
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:
'set the Friday day position in the empty cells range/area:
mtchFr = Application.match("Friday", sh.Range(sh.cells(2, A.cells(1).column), sh.cells(2, A.cells(A.Columns.count).column)), 0)
If A.Columns.count - mtchFr < 6 Then 'no any FTGap existing:
Gap = Gap + 1
ElseIf A.cells.count - mtchFr = 6 Then 'fix a FTGap
Gap = Gap + 1: FTGap = FTGap + 1
Else
bigGaps = ((A.cells.count - mtchFr) - i + 1) / 7
FTGap = FTGap + Int(bigGaps)
If mtchFr <> 1 Then Gap = Gap + 1 'the gap before Friday
If A.cells.count - i + 1 - Int(bigGaps) * 7 > 0 Then Gap = Gap + 1
End If
End If
Next A
countGaps = Array(Gap, FTGap)
End Function

Answer 2

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.