VBA code to insert rows so that each item has the same number of rows

[JeffGrant]

Hi All,

I am trying to modify some vba code supplied by Alan Sidman, thank you Alan .

What I would like to end up with is 3 of each item/name in column A. I think my approach is completely wrong, and would dearly love some direction.

Option Explicit

Sub CountNames()
    Dim i, r As Integer, lr As Long
    lr = Range("A" & Rows.Count).End(xlUp).Row
    i = 3
Do Until i = Cells(Rows.Count, 1).End(xlUp).Row
      For r = 1 To 3
        If Range("A" & i) = Range("A" & i - 1) Then
            GoTo Skip
        ElseIf Range("A" & i) <> Range("A" & i - 1) And r = 2 Then
            GoTo Skip
        Else:   Range("A" & i).Offset(1, 0).EntireRow.Insert
                Range("A" & i).Offset(1, 0) = Range("A" & i)
                i = i + 1
        End If
Skip:
      Next r
      i = i + 1
Loop
    MsgBox "completed"
    
End Sub

Book1
	A
1	Name
2	Jeff
3	Jeff
4	Tom
5	Tom
6	Fred
7	Fred
8	Fred
9	Dee
10	Dee
11	KT
12	KT
Sheet1

 

[JeffGrant]

Figured it out. Just needed a cup of coffee. Not the nicest solution but it works.

Option Explicit
Sub InsertRowsUpToThreeRows()
    Dim rw     As Long
    Dim cnt    As Long
    Application.ScreenUpdating = False
    With ActiveSheet
        For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
            If .Cells(rw, 1) = .Cells(rw - 1, 1) Then   'compare rows
                cnt = cnt + 1                           'and count if equal
                
            ElseIf cnt = 1 And .Cells(rw, 1) <> .Cells(rw - 1, 1) Then .Cells(rw, 1).EntireRow.Insert 'insert row
                .Cells(rw, 1) = .Cells(rw + 1, 1)       'write value
                cnt = 0                                 'reset counter
            
            ElseIf cnt = 0 And .Cells(rw, 1) <> .Cells(rw - 1, 1) Then .Cells(rw, 1).EntireRow.Insert
                .Cells(rw, 1) = .Cells(rw + 1, 1)       'write value
                cnt = cnt + 1                           'count if value written
                rw = rw + 1                             'add to row counter to compensate for the loop count
            
            Else
                If cnt = 2 And .Cells(rw, 1) <> .Cells(rw - 1, 1) Then cnt = 0  'start next block
            
            End If
        Next rw
    End With
    Application.ScreenUpdating = True
    MsgBox "Done"
End Sub