May I ask if it's possible to insert rows based on (3 - the number of occurrence of a value)

[SLLRL]

Hi experts, I'm looking into the possibilities of inserting rows if the occurrence of a value is not 3, example as below. Thanks!

Original:

Employee ID
111
222
222
333
333
333
444

Expected:

Employee ID
111
222
222
333
333
333
444

 

[Joe4]

Welcome to the Board!

Assuming that:
- Your data is in column A and begins on row 2 (row 1 is a header)
- Your data in column A is already sorted (if not, we can add code to do that)
Here is VBA code that should do what you want:

Sub MyInsertRows()

    Dim lr As Long
    Dim r As Long
    Dim ct As Long
    Dim cur As Variant
    Dim prv As Variant
    
    Application.ScreenUpdating = False
    
'   Find last row with data in column A
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    
'   Loop through all rows backwards, up to row 2
    For r = lr To 2 Step -1
'       Get current value
        cur = Cells(r, "A")
'       Count number of records in column matching value in column A
        ct = Application.WorksheetFunction.CountIf(Range("A:A"), cur)
'       If count is less than three and a different value, then insert rows below
        If (ct < 3) And (cur <> prv) Then
            Rows(r + 1 & ":" & r + 3 - ct).Insert
        End If
'       Set previous value to current value
        prv = cur
    Next r
    
    Application.ScreenUpdating = True
    
    MsgBox "Macro complete!"
    
End Sub

 

[SLLRL]

Welcome to the Board!

Assuming that:
- Your data is in column A and begins on row 2 (row 1 is a header)
- Your data in column A is already sorted (if not, we can add code to do that)
Here is VBA code that should do what you want:

Sub MyInsertRows()

    Dim lr As Long
    Dim r As Long
    Dim ct As Long
    Dim cur As Variant
    Dim prv As Variant
   
    Application.ScreenUpdating = False
   
'   Find last row with data in column A
    lr = Cells(Rows.Count, "A").End(xlUp).Row
   
'   Loop through all rows backwards, up to row 2
    For r = lr To 2 Step -1
'       Get current value
        cur = Cells(r, "A")
'       Count number of records in column matching value in column A
        ct = Application.WorksheetFunction.CountIf(Range("A:A"), cur)
'       If count is less than three and a different value, then insert rows below
        If (ct < 3) And (cur <> prv) Then
            Rows(r + 1 & ":" & r + 3 - ct).Insert
        End If
'       Set previous value to current value
        prv = cur
    Next r
   
    Application.ScreenUpdating = True
   
    MsgBox "Macro complete!"
   
End Sub

Thank you so much Joe. It works perfectly with small group of data, e.g. ~500 rows but when I tried to include more it started to not work.

I am examining the VBA in details myself but thank you for giving a great reference for me to start with

 

[Joe4]

Thank you so much Joe. It works perfectly with small group of data, e.g. ~500 rows but when I tried to include more it started to not work.

It should not have any problem with 500 rows. I don't there is anything in the code that would cause the number of rows to affect how it works.
The only issue I can think of that may cause issues is if you have one of the following conditions:
- rows are not sorted to start
- you already have some blank rows within your data
- you have some rows with errors in them

Do you have any of those conditions?
If not, and you still are having issues, show us the portion of your data that is not working properly.