Insert blank row in every given group number of row based in month - VBA

[SilentRomance]

Hello guys
Here's my problem
I'm trying to insert blank row in my data sheet in every group number given (ex. after 5 or 10 rows) based on month.
It will add and add blank row until the end of a month (ex. September) and if there is another month (ex. October) it will start counting based on group number given (ex. after 5 or 10 rows) and insert blank row until the end of that month (October).

Example, this the data:

GF - Lagawe.xlsm
	A
1	08-Sep-21
2	09-Sep-21
3	10-Sep-21
4	11-Sep-21
5	12-Sep-21
6	13-Sep-21
7	14-Sep-21
8	15-Sep-21
9	16-Sep-21
10	17-Sep-21
11	18-Sep-21
12	19-Sep-21
13	20-Sep-21
14	01-Oct-21
15	02-Oct-21
16	03-Oct-21
17	04-Oct-21
18	05-Oct-21
19	06-Oct-21
20	07-Oct-21
21	08-Oct-21
22	09-Oct-21
23	10-Oct-21
24	11-Oct-21
25	12-Oct-21
26	03-Nov-21
27	04-Nov-21
28	05-Nov-21
29	06-Nov-21
30	07-Nov-21
31	08-Nov-21
32	09-Nov-21
33	10-Nov-21
34	11-Nov-21
35	12-Nov-21
36	13-Nov-21
37	14-Nov-21
38	15-Nov-21
39	16-Nov-21
40	17-Nov-21
Sheet1

If run a code I want to be like this:

GF - Lagawe.xlsm
	A
1	08-Sep-21
2	09-Sep-21
3	10-Sep-21
4	11-Sep-21
5	12-Sep-21
6
7	13-Sep-21
8	14-Sep-21
9	15-Sep-21
10	16-Sep-21
11	17-Sep-21
12
13	18-Sep-21
14	19-Sep-21
15	20-Sep-21
16
17	01-Oct-21
18	02-Oct-21
19	03-Oct-21
20	04-Oct-21
21	05-Oct-21
22
23	06-Oct-21
24	07-Oct-21
25	08-Oct-21
26	09-Oct-21
27	10-Oct-21
28
29	11-Oct-21
30	12-Oct-21
31
32	03-Nov-21
33	04-Nov-21
34	05-Nov-21
35	06-Nov-21
36	07-Nov-21
37
38	08-Nov-21
39	09-Nov-21
40	10-Nov-21
41	11-Nov-21
42	12-Nov-21
43
44	13-Nov-21
45	14-Nov-21
46	15-Nov-21
47	16-Nov-21
48	17-Nov-21
Sheet1

Can you help me guys. Thanks!

 

[Peter_SSs]

Give this a try with a copy of your workbook

Sub Insert_Rows()
  Dim a As Variant
  Dim i As Long, k As Long, xtra As Long
  
  Const NumRows As Long = 5
  
  a = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
  Application.ScreenUpdating = False
  For i = 2 To UBound(a)
    If Month(a(i, 1)) <> Month(a(i - 1, 1)) Or k = NumRows - 1 Then
      Rows(i + xtra).Insert
      xtra = xtra + 1
      k = 0
    Else
      k = k + 1
    End If
  Next i
  Application.ScreenUpdating = True
End Sub

 

[Trebor76]

Hi SilenceRomance,

Though Peter has beaten me to the punch and I would actually use his solution, here is mine proposed solution nonetheless:

Option Explicit
Sub Macro1()

    Dim lngBlock As Long, i As Long
    Dim lngMyRow As Long, lngLastRow As Long
    Dim strSrcCol As String
    Dim ws As Worksheet
    Dim rngRowInsert As Range
    
    Application.ScreenUpdating = False
    
    lngBlock = 5 'Number of days in a month before inserting a blank row. Change to suit if necessary.
    Set ws = ThisWorkbook.Sheets("Sheet1") 'Name of sheet with dates. Change to suit if necessary.
    strSrcCol = "A" 'Column containing the dates in 'ws'. Change to suit if necessary.
    lngLastRow = ws.Cells(Rows.Count, strSrcCol).End(xlUp).Row
    
    For lngMyRow = 1 To lngLastRow
        If DateDiff("m", ws.Range(strSrcCol & lngMyRow), Range(strSrcCol & lngMyRow + 1)) > 0 Then
            If rngRowInsert Is Nothing Then
                Set rngRowInsert = ws.Range("A" & lngMyRow + 1)
            Else
                Set rngRowInsert = Union(rngRowInsert, ws.Range("A" & lngMyRow + 1))
            End If
            i = 0
        Else
            i = i + 1
            If i = lngBlock Then
                If rngRowInsert Is Nothing Then
                    Set rngRowInsert = ws.Range("A" & lngMyRow + 1)
                Else
                    Set rngRowInsert = Union(rngRowInsert, ws.Range("A" & lngMyRow + 1))
                End If
                i = 0
            End If
        End If
    Next lngMyRow
    
    If Not rngRowInsert Is Nothing Then
        rngRowInsert.Insert Shift:=xlDown
    End If
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[SilentRomance]

Give this a try with a copy of your workbook

Sub Insert_Rows()
  Dim a As Variant
  Dim i As Long, k As Long, xtra As Long
 
  Const NumRows As Long = 5
 
  a = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
  Application.ScreenUpdating = False
  For i = 2 To UBound(a)
    If Month(a(i, 1)) <> Month(a(i - 1, 1)) Or k = NumRows - 1 Then
      Rows(i + xtra).Insert
      xtra = xtra + 1
      k = 0
    Else
      k = k + 1
    End If
  Next i
  Application.ScreenUpdating = True
End Sub

Thank you very much bro!

 

[SilentRomance]

Hi SilenceRomance,

Though Peter has beaten me to the punch and I would actually use his solution, here is mine proposed solution nonetheless:

Option Explicit
Sub Macro1()

    Dim lngBlock As Long, i As Long
    Dim lngMyRow As Long, lngLastRow As Long
    Dim strSrcCol As String
    Dim ws As Worksheet
    Dim rngRowInsert As Range
   
    Application.ScreenUpdating = False
   
    lngBlock = 5 'Number of days in a month before inserting a blank row. Change to suit if necessary.
    Set ws = ThisWorkbook.Sheets("Sheet1") 'Name of sheet with dates. Change to suit if necessary.
    strSrcCol = "A" 'Column containing the dates in 'ws'. Change to suit if necessary.
    lngLastRow = ws.Cells(Rows.Count, strSrcCol).End(xlUp).Row
   
    For lngMyRow = 1 To lngLastRow
        If DateDiff("m", ws.Range(strSrcCol & lngMyRow), Range(strSrcCol & lngMyRow + 1)) > 0 Then
            If rngRowInsert Is Nothing Then
                Set rngRowInsert = ws.Range("A" & lngMyRow + 1)
            Else
                Set rngRowInsert = Union(rngRowInsert, ws.Range("A" & lngMyRow + 1))
            End If
            i = 0
        Else
            i = i + 1
            If i = lngBlock Then
                If rngRowInsert Is Nothing Then
                    Set rngRowInsert = ws.Range("A" & lngMyRow + 1)
                Else
                    Set rngRowInsert = Union(rngRowInsert, ws.Range("A" & lngMyRow + 1))
                End If
                i = 0
            End If
        End If
    Next lngMyRow
   
    If Not rngRowInsert Is Nothing Then
        rngRowInsert.Insert Shift:=xlDown
    End If
   
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

Thanks bro! It work also

 

[Peter_SSs]

You're welcome. Glad we could help. Thanks for the follow-up.