VBA for Excel to fill missing weekdays in a range and mark “New Mondays”

Question

I am newly learning VBA for MS Excel 2007. I wrote a simple loop to fill in missing days of the week, as follows. So the same lines are repeated for each pair of consecutive days just with names of days changed (I omitted all but two here because it got too lengthy). The only caveat is that I want "New" to be added to the cell to the right whenever a new cell with value "Monday" is created. So there is the extra line i.range("B2").Value = "New" for the first block.

Sub FillWeek()

For Each i In Selection
    If i.Value = "Sunday" And i.Range("A2") <> "Monday" Then
        i.Range("A2").Insert
        i.Range("A2").Value = "Monday"
        i.Range("B2").Value = "New"
        i.Range("A2").Interior.Color = 192
    End If

Next i
        
For Each i In Selection
    If i.Value = "Monday" And i.Range("A2") <> "Tuesday" Then
        i.Range("A2").Insert
        i.Range("A2").Value = "Tuesday"
        i.Range("A2").Interior.Color = 192
    End If

Next i

#And the code continues for all other consecutive days pairs

I selected the leftmost cells below, and the results are given here in columns 2 and 3 (in Excel they were given in columns 1 and 2). I've put the unexpected ones in italics.

Row 1 (Selection)	The result (which just replaced column 1)	(And this was added to column 2)
Sunday	Sunday
Tuesday	Monday	New
Wednesday	Tuesday
Thursday	Wednesday
Sunday	Thursday
Wednesday	Friday
Saturday	Saturday	New
Monday	Sunday
Wednesday	Monday
	Tuesday
	Wednesday
	Thursday
	Saturday
	Monday
	Wednesday

Unexpected Results

1. Why was "New" not added just next to Monday, it has been added once next to Saturday, and then it was not added next to Monday once?

2. Why were Friday not added after Thursday and Sunday not added after Saturday towards the end?

Answer 1

Here is one way:

Sub AddDays()
Dim days As Variant
Dim ct As Long
Dim startCell As Range
days = Array("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday")
On Error Resume Next
Set startCell = Application.InputBox("Select the first cell containing days of the week", "Days of week check", ActiveCell.Address, , , , , 8)
On Error Goto 0
If Not startCell Is Nothing Then
    Do
        If startCell.Offset(ct).Value <> days(ct) Then
            startCell.Offset(ct).EntireRow.Insert
            startCell.Offset(ct).Value = days(ct)
            startCell.Offset(ct, 1).Value = "New"
        Else
            ct = ct + 1
        End If
    Loop Until ct >= 7
End If

End Sub

Answer 2

Try this code. Processing is performed from the active cell. You can start with any day of the week. Processes a variable number of weeks

Sub FillDays()
    Dim dict As New Collection, cl As Range, arr, cur, nxt, mst
    arr = Split("Sunday Monday Tuesday Wednesday Thursday Friday Saturday")
    For cur = 0 To UBound(arr)
        dict.Add cur, arr(cur)       'make the dict name:index, key = name, e.g. "Sunday":0 to get the index by name
    Next
    
    Set cl = ActiveCell   'get the start cell
    Do While True
        cur = cl.Text           'get the text from the current cell
        nxt = cl.Offset(1).Text 'get the text from the next cell
        If cur = "" Or nxt = "" Then Exit Do    'if current cell or next cell is empty then exit loop
        cur = dict(cur)           'get the index of the day of the week from the current cell
        nxt = dict(nxt)           'get the index of the day of the week from the next cell
        mst = (cur + 1) Mod 7   'calculate the proper index for the next cell
        If mst <> nxt Then      'if expected weekday <> next weekday
            'add the expected weekday and shift to the next cell
            cl.Offset(1).EntireRow.Insert
            Set cl = cl.Offset(1)
            cl.Value = arr(mst)
            If mst = 1 Then cl.Offset(, 1) = "New"  'a new cell with value "Monday" is created
            cl.Resize(, 2).Font.Bold = True 'debug
        Else    'if expected weekday = next weekday
            Set cl = cl.Offset(1)   'shift to the next cell only
        End If
    Loop
End Sub

Edit 2

Added features: not case-sensitive, resistant to extra spaces, handles incorrect weekday names

Sub FillDays()
    Dim dict As New Collection, cl As Range, arr, cur, nxt, mst
    arr = Split(LCase("Sunday Monday Tuesday Wednesday Thursday Friday Saturday"))
    For cur = 0 To UBound(arr)
        dict.Add cur, arr(cur)       'make the dict name:index, key = name, e.g. "Sunday":0 to get the index by name
    Next
    
    Set cl = ActiveCell   'get the start cell
    Do While True
        cur = LCase(Trim(cl.Text))      'get the text from the current cell
        Set cl = cl.Offset(1)           'move to the next cell
        nxt = LCase(Trim(cl.Text))      'get the text from the next cell
        On Error Resume Next
        cur = dict(cur)         'get the index of the day of the week from the current cell
        nxt = dict(nxt)         'get the index of the day of the week from the next cell
        'if the cells do not contain the day of the week or is empty >> exit
        If cur = "" Or nxt = "" Or Err.Number <> 0 Then Exit Do
        On Error GoTo 0
        mst = (cur + 1) Mod 7   'calculate the proper index for the next cell
        If mst <> nxt Then      'if expected weekday <> next weekday
            'add the expected weekday and shift to the next cell
            cl.EntireRow.Insert ' side effect: shifts the cl to the next row
            Set cl = cl.Offset(-1)  'compensate for the side effect
            cl.Value = WorksheetFunction.Proper(arr(mst))   'Capitalized name
            If mst = 1 Then cl.Offset(, 1) = "New"  'a new cell with value "Monday" is created
            cl.Resize(, 2).Font.Bold = True 'debug
        End If
    Loop
End Sub

Result of Edit2