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!
 

jolivanes

Well-known Member
Joined
Sep 5, 2004
Messages
1,712
Office Version
  1. 2013
  2. 2007
Platform
  1. Windows
Hi Peter.
It was not meant to say who is right or who is wrong or which is fast and which is slow. Just an observation. Anyway, the macros were both used on the same data structure.
I also used the insert entire rows as well as resize 8 columns in the code i have and it made very little difference.
A few seconds here and there while you sit at home being a good citizen with this Covid problem should not break the bank.
All of this becomes moot because of your latest code. You're cooking with gas there.
 

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.

agarci1096

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



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

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
Hi, sorry I replied pretty late, but thanks so much for your help. v2 worked perfect.
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,560
Office Version
  1. 365
Platform
  1. Windows
Glad it worked for you. Thanks for the follow-up, :)
 

Watch MrExcel Video

Forum statistics

Threads
1,130,129
Messages
5,640,296
Members
417,135
Latest member
zeusmining

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