See below an image of my Excel Spreadsheet.

What I am trying to accomplish is add 3 blank rows atop of only the first instance each sequential month. So if a new month begins in February (or "2" basically), then 3 blank rows will be automatically added atop of it. I am trying to do this using VBA code. However, my problem runs into how certain functions treat numbers and dates(especially) different from text/strings.

My current VBA code Sub insert() (shown under my image file) uses the LEFT() function on cell A2, but it does not return the value I want, which is "1" or "01" (representing the numerical value of its month). Instead it returns its actual value "44200" etc. - not what I want. I need to find a way to have my VBA code do its job by inserting 3 blank rows atop of each new month. But it can't do that with the LEFT() function. And the MONTH() function won't work in that code either. How do I go about this and alter this code to make it work? Thank you for your help.

Sub insert()

Dim lastRow As Long
Dim done As Boolean

'change A to the longest column (most rows)
lastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

For i = 1 To lastRow
    'change the 1 below to the necessary column (ie, use 4 for column D)
    If Left(Cells(i, 1), 2) = "01" Then
    Rows(i).insert
    done = True
    i = i   1
    End If
    If done = True Then Exit For
Next

End Sub

CodePudding user response：

Insert Rows on Month Change

• On each change of month in cells of column A, it will insert 3 rows above the cell.
• It loops from top to bottom and combines the critical cells (or the cells next to them) into a range: first the current cell then the previously combined cells. It alternates between the cells and the cells next to them to not get ranges of multiple cells (Application.Union in GetCombinedRangeReverse: Union([A1], [A2]) = [A1:A2], while Union ([A1], [B2]) = [A1,B2]).
• In the end, it loops through the cells of the range to insert rows from bottom to top.

Option Explicit

Sub InsertRows()
    
    Const fRow As Long = 2 ' First Row
    Const dtCol As String = "A" ' Date Column
    Const RowsToInsert As Long = 3
    
    ' Pick one:
    ' 1. Either (bad, but sometimes necessary)...
    'Dim ws As Worksheet: Set ws = ActiveSheet ' could be the wrong one
    ' 2. ... or better...
    'Dim wb As Workbook: Set wb = ThisWorkbook  ' workbook containing this code
    'Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1") ' name
    ' 3. ... or best:
    Dim ws As Worksheet: Set ws = Sheet1 ' code name (not in parentheses)
    
    Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, dtCol).End(xlUp).Row
    
    Dim irg As Range ' Insert Range
    Dim pMonth As Long ' Previous Month
    Dim cMonth As Long ' Current Month
    Dim cValue As Variant ' Current Cell Value
    Dim cOffset As Long ' Column Offset for GetCombinedRangeReverse
    Dim r As Long
    
    For r = fRow To lRow
        cValue = ws.Cells(r, dtCol).Value
        If IsDate(cValue) Then ' a date
            cMonth = Month(cValue)
            If cMonth <> pMonth Then ' a different month
                pMonth = cMonth
                ' Changing the column to cover consecutive different months.
                cOffset = IIf(cOffset = 0, 1, 0)
                Set irg = GetCombinedRangeReverse(irg, _
                    ws.Cells(r, dtCol).Offset(, cOffset))
            Else ' the same month
            End If
        Else ' not a date
        End If
    Next r
    
    If irg Is Nothing Then Exit Sub
    
    ' This loop is running from bottom to top due to 'GetCombinedRangeReverse'.
    Dim iCell As Range
    For Each iCell In irg.Cells
        iCell.Resize(RowsToInsert).EntireRow.insert
    Next iCell

    MsgBox "Rows inserted.", vbInformation, "Insert Rows"

End Sub

Function GetCombinedRangeReverse( _
    ByVal CombinedRange As Range, _
    ByVal AddRange As Range) _
As Range
    If CombinedRange Is Nothing Then
        Set GetCombinedRangeReverse = AddRange
    Else
        Set GetCombinedRangeReverse = Union(AddRange, CombinedRange)
    End If
End Function