I need a VBA to count groups of 4 rows and insert a row if there are less than 4 rows to the group

[agarci1096]

Hi, I have a data set that has rows numbered groups of 4 rows counting up from 0 to 100. It will then start over at 0 and count up to 100 again, and repeat this several thousand times.
Like this:
Column H ---- Column I
0
0
0
0
1
1
1
1

However some groups will only have 2 or 3 rows and it needs to be 4
Like this:
Column H ---- Column I
2
2
3
3
3

I'm fairly new at macros and am pretty lost on this whole thing. I need a VBA that will insert a row with the number of the group if there are less than 4 rows to a group. Any help on where to start with this would be greatly appreciated!

 

[Peter_SSs]

Welcome to the MrExcel board!

Assuming a header row 1 and those groups of numbers start on row 2, try this with a copy of your workbook.

Sub Insert_Rows()
  Dim a As Variant
  Dim i As Long, j As Long
  
  a = Range("H1", Range("H" & Rows.Count).End(xlUp)).Value
  i = UBound(a)
  Application.ScreenUpdating = False
  Do
    For j = 1 To 3
      If a(i - j, 1) <> a(i, 1) Or i - j < 2 Then
        Rows(i).Copy
        Rows(i + 1).Resize(4 - j).Insert
        Exit For
      End If
    Next j
    i = i - j
  Loop Until i = 1
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

 

[jolivanes]

Also assuming a header row, so starts at A2.
Included the possibility of having just a single value. If not required, you can delete that part.
Change the Column reference where required for Column H

Sub Maybe()
Dim i As Long, j As Long
i = 2
Application.ScreenUpdating = False
    Do Until Cells(i, 1).Value = ""
        If Cells(i, 1).Offset(1) <> Cells(i, 1) Then    '<---- Change the (i, 1) to (i, 8) for Column H
            Cells(i, 1).Offset(1).Resize(3).Insert Shift:=xlDown   '<---- Change the (i, 1) to (i, 8) for Column H
            Cells(i, 1).Offset(1).Resize(3).Value = Cells(i, 1).Value   '<---- Change the (i, 1) to (i, 8) for Column H
                ElseIf Cells(i, 1).Offset(3).Value <> Cells(i, 1).Value Then   '<---- Change the (i, 1) to (i, 8) for Column H
                j = Application.WorksheetFunction.CountIf(Range(Cells(i, 1), Cells(i + 3, 1)), Cells(i, 1).Value)   '<---- Change the (i, 1) to (i, 8) for Column H
                Cells(i, 1).Offset(1).Resize(4 - j).Insert Shift:=xlDown    '<---- Change the (i, 1) to (i, 8) for Column H
                Cells(i, 1).Offset(1).Resize(3).Value = Cells(i, 1).Value   '<---- Change the (i, 1) to (i, 8) for Column H
        End If
        i = i + 4
    Loop
Application.ScreenUpdating = True
End Sub

 

[agarci1096]

Welcome to the MrExcel board!

Assuming a header row 1 and those groups of numbers start on row 2, try this with a copy of your workbook.

Sub Insert_Rows()
  Dim a As Variant
  Dim i As Long, j As Long
 
  a = Range("H1", Range("H" & Rows.Count).End(xlUp)).Value
  i = UBound(a)
  Application.ScreenUpdating = False
  Do
    For j = 1 To 3
      If a(i - j, 1) <> a(i, 1) Or i - j < 2 Then
        Rows(i).Copy
        Rows(i + 1).Resize(4 - j).Insert
        Exit For
      End If
    Next j
    i = i - j
  Loop Until i = 1
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

Thanks for the reply. I'm not sure if it works though because its currently still running.

 

[Peter_SSs]

I'm not sure if it works though because its currently still running.

Did it ever finish? You did imply that there was a lot of data ..

counting up from 0 to 100. It will then start over at 0 and count up to 100 again, and repeat this several thousand times.

Does your worksheet have a lot of formulas in it?

Is there any vba in, or acting on, your workbook?

 

[agarci1096]

Did it ever finish? You did imply that there was a lot of data ..

Does your worksheet have a lot of formulas in it?

Is there any vba in, or acting on, your workbook?

Yeah, there is about 200,000 rows. I don't think there are any other vba or formulas on it. It is just a record of plant monitoring data. Yeah, no it never finished.

 

[jolivanes]

Looping on a Sheet with 200,000 Rows should take a while but if you start before Lunch, it should be finished by the time you get back.

 

[agarci1096]

Did it ever finish? You did imply that there was a lot of data ..

Does your worksheet have a lot of formulas in it?

Is there any vba in, or acting on, your workbook?

Hi, so I tried it

Welcome to the MrExcel board!

Assuming a header row 1 and those groups of numbers start on row 2, try this with a copy of your workbook.

Sub Insert_Rows()
  Dim a As Variant
  Dim i As Long, j As Long

  a = Range("H1", Range("H" & Rows.Count).End(xlUp)).Value
  i = UBound(a)
  Application.ScreenUpdating = False
  Do
    For j = 1 To 3
      If a(i - j, 1) <> a(i, 1) Or i - j < 2 Then
        Rows(i).Copy
        Rows(i + 1).Resize(4 - j).Insert
        Exit For
      End If
    Next j
    i = i - j
  Loop Until i = 1
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

Okay, so I tried it on a smaller section of the worksheet, and it seemed to work just fine. I'm just not sure why its taking so long to run over the whole thing! Anyway, thanks for your help. I was just wondering if there is a way I could change the code so that it leaves the new rows blank?

 

[jolivanes]

Code from Post #2
Start with 25,025 data cells, finish with 36,037 cells.
1min 20 sec

Code from Post #3
Start with 25,025 data cells, finish with 36,037 cells.
1min 1 sec

This code. No filling of inserted cells, no checking for just a single cell with data.
57 sec

I don't know how close you be with multiplying these outcomes by 8.

Sub Maybe_NoFill()
Dim i As Long, j As Long
Dim t
t = Timer
i = 2
Application.ScreenUpdating = False
    Do Until Cells(i, 1).Value = ""
                If Cells(i, 1).Offset(3).Value <> Cells(i, 1).Value Then
                j = Application.WorksheetFunction.CountIf(Range(Cells(i, 1), Cells(i + 3, 1)), Cells(i, 1).Value)
                Cells(i, 1).Offset(1).Resize(4 - j).Insert Shift:=xlDown
        End If
        i = i + 4
    Loop
Application.ScreenUpdating = True
MsgBox "This macro took " & Format(Round(Timer - t, 2), "00:00:00.00") & " seconds to run."
End Sub

Note: All references are for Column A. Change where required.

 

[Peter_SSs]

Code from Post #2
Start with 25,025 data cells, finish with 36,037 cells.
1min 20 sec

Code from Post #3
Start with 25,025 data cells, finish with 36,037 cells.
1min 1 sec

I'm not suggesting that my code is right or yours is wrong but I do note that the codes are doing different things, so it isn't too surprising that the times are different. If you test with some data in other columns (which I assume there is since this number data is in column H) you will see.

I was just wondering if there is a way I could change the code so that it leaves the new rows blank?

Not certain what you mean by this as earlier you said ..

I need a VBA that will insert a row with the number of the group if there are less than 4 rows to a group.

So, I am assuming that you mean to leave all the other columns empty, not filling them with the above data like my previous code did. If so, you could try this code.
For me, with 200,000 rows to start, ending with 510,000 rows the code took about 2.6 seconds.

Sub Insert_Rows_v2()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, nc As Long, nr As Long, lr As Long

  lr = Range("H" & Rows.Count).End(xlUp).Row
  a = Range("H1:H" & lr + 3).Value
  i = 2
  nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
  ReDim b(1 To Rows.Count, 1 To 1)
  b(1, 1) = 1
  nr = lr
  Do
    b(i, 1) = i
    For j = 1 To 3
      If a(i + j, 1) <> a(i, 1) Or i + j > UBound(a) Then
        For k = 0 To j - 1
          b(i + k, 1) = i
        Next k
        For k = 1 To 4 - j
          b(nr + k, 1) = i
        Next k
        nr = nr + 4 - j
        Exit For
      Else
        b(i + j, 1) = i
      End If
    Next j
    i = i + j
  Loop Until i > lr
  If nr > lr Then
    Application.ScreenUpdating = False
      With Range("A1").Resize(nr, nc)
        .Columns(nc).Value = b
        .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlYes
        a = .Columns("H").Value
        For i = 2 To nr Step 4
          For j = 1 To 3
            a(i + j, 1) = a(i, 1)
          Next j
        Next i
        .Columns("H").Value = a
        .Columns(nc).ClearContents
      End With
    Application.ScreenUpdating = True
  End If
End Sub

Here is a small sample.
Before:

agarci.xlsm
	A	B	C	D	E	F	G	H	I
1	Hdr 1	Hdr 2	Hdr 3	Hdr 4	Hdr 5	Hdr 6	Hdr 7	Hdr 8	Hdr 9
2	A2	B2	C2	D2	E2	F2	G2	1	I2
3	A3	B3	C3	D3	E3	F3	G3	1	I3
4	A4	B4	C4	D4	E4	F4	G4	3	I4
5	A5	B5	C5	D5	E5	F5	G5	5	I5
6	A6	B6	C6	D6	E6	F6	G6	5	I6
7	A7	B7	C7	D7	E7	F7	G7	5	I7
8	A8	B8	C8	D8	E8	F8	G8	5	I8
9	A9	B9	C9	D9	E9	F9	G9	8	I9
10	A10	B10	C10	D10	E10	F10	G10	8	I10
11	A11	B11	C11	D11	E11	F11	G11	10	I11
12	A12	B12	C12	D12	E12	F12	G12	10	I12
13	A13	B13	C13	D13	E13	F13	G13	10	I13
14	A14	B14	C14	D14	E14	F14	G14	10	I14
15
Sample

After:

agarci.xlsm
	A	B	C	D	E	F	G	H	I
1	Hdr 1	Hdr 2	Hdr 3	Hdr 4	Hdr 5	Hdr 6	Hdr 7	Hdr 8	Hdr 9
2	A2	B2	C2	D2	E2	F2	G2	1	I2
3	A3	B3	C3	D3	E3	F3	G3	1	I3
4								1
5								1
6	A4	B4	C4	D4	E4	F4	G4	3	I4
7								3
8								3
9								3
10	A5	B5	C5	D5	E5	F5	G5	5	I5
11	A6	B6	C6	D6	E6	F6	G6	5	I6
12	A7	B7	C7	D7	E7	F7	G7	5	I7
13	A8	B8	C8	D8	E8	F8	G8	5	I8
14	A9	B9	C9	D9	E9	F9	G9	8	I9
15	A10	B10	C10	D10	E10	F10	G10	8	I10
16								8
17								8
18	A11	B11	C11	D11	E11	F11	G11	10	I11
19	A12	B12	C12	D12	E12	F12	G12	10	I12
20	A13	B13	C13	D13	E13	F13	G13	10	I13
21	A14	B14	C14	D14	E14	F14	G14	10	I14
22
Sample