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

New Member
Joined
Nov 25, 2020
Messages
15
Office Version
  1. 365
Platform
  1. Windows
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!
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,589
Office Version
  1. 365
Platform
  1. Windows
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.

VBA Code:
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
 
Solution

jolivanes

Well-known Member
Joined
Sep 5, 2004
Messages
1,712
Office Version
  1. 2013
  2. 2007
Platform
  1. Windows
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
VBA Code:
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

New Member
Joined
Nov 25, 2020
Messages
15
Office Version
  1. 365
Platform
  1. Windows
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.

VBA Code:
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

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,589
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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

New Member
Joined
Nov 25, 2020
Messages
15
Office Version
  1. 365
Platform
  1. Windows
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

Well-known Member
Joined
Sep 5, 2004
Messages
1,712
Office Version
  1. 2013
  2. 2007
Platform
  1. Windows

ADVERTISEMENT

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

New Member
Joined
Nov 25, 2020
Messages
15
Office Version
  1. 365
Platform
  1. Windows
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.

VBA Code:
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

Well-known Member
Joined
Sep 5, 2004
Messages
1,712
Office Version
  1. 2013
  2. 2007
Platform
  1. Windows
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.

Code:
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

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,589
Office Version
  1. 365
Platform
  1. Windows
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.

VBA Code:
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
ABCDEFGHI
1Hdr 1Hdr 2Hdr 3Hdr 4Hdr 5Hdr 6Hdr 7Hdr 8Hdr 9
2A2B2C2D2E2F2G21I2
3A3B3C3D3E3F3G31I3
4A4B4C4D4E4F4G43I4
5A5B5C5D5E5F5G55I5
6A6B6C6D6E6F6G65I6
7A7B7C7D7E7F7G75I7
8A8B8C8D8E8F8G85I8
9A9B9C9D9E9F9G98I9
10A10B10C10D10E10F10G108I10
11A11B11C11D11E11F11G1110I11
12A12B12C12D12E12F12G1210I12
13A13B13C13D13E13F13G1310I13
14A14B14C14D14E14F14G1410I14
15
Sample


After:

agarci.xlsm
ABCDEFGHI
1Hdr 1Hdr 2Hdr 3Hdr 4Hdr 5Hdr 6Hdr 7Hdr 8Hdr 9
2A2B2C2D2E2F2G21I2
3A3B3C3D3E3F3G31I3
41
51
6A4B4C4D4E4F4G43I4
73
83
93
10A5B5C5D5E5F5G55I5
11A6B6C6D6E6F6G65I6
12A7B7C7D7E7F7G75I7
13A8B8C8D8E8F8G85I8
14A9B9C9D9E9F9G98I9
15A10B10C10D10E10F10G108I10
168
178
18A11B11C11D11E11F11G1110I11
19A12B12C12D12E12F12G1210I12
20A13B13C13D13E13F13G1310I13
21A14B14C14D14E14F14G1410I14
22
Sample
 

Watch MrExcel Video

Forum statistics

Threads
1,130,322
Messages
5,641,526
Members
417,213
Latest member
wikk

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top