insert blank rows every nth row and copy down data to fill blank rows

Hi,

I am working with a large spreadsheet with over 50000 rows containing data for 107 participants in a study observed 480 times. I originally had 476 observations, but now need to ad the four extra observations for each participant. There are some data that just need to be copied down from the previous information to fill the 4 new rows per participant (e.g., Vars 1-4 below). The other variables (e.g., Vars 20-22) change over time, so I will be entering them manually.

Data format is as follows:

Participant Time Var 1 Var 2 Var 3 Var 4 .....Var 20 Var 21 Var 22...
1 1 a1 b1 c1 d1 x11 y11 z11
1 2 a1 b1 c1 d1 x12 y12 z12
1 3 a1 b1 c1 d1 x13 y13 z13
1 4 a1 b1 c1 d1 x14 y14 z14
2 1 a2 b2 c2 d2 x21 y21 z21
2 2 a2 b2 c2 d2 x22 y22 z22
2 3 a2 b2 c2 d2 x23 y23 z23
2 4 a2 b2 c2 d2 x24 y24 z24

So, my task is as follows:

1. For each participant number listed in column 1, insert 4 blank rows at the end. Skip down 476 rows and insert 4 more blank rows, and so on.
2. Copy down variables that are common (Vars 1-4 in the example above) into the blank rows for each participant.


Could anyone help me with the script for this?

Thanks

SR

Thanks, and sorry for not being clear. The 4 news rows need to be added at the change from 1 to 2, and again from the change from 2 to 3, and so on. So, row 476 for participant 1 contains some data that I need to be copied to the four new rows for participant 1. Similarly, I need the data from the 476th row for participant 2 to be copied into the four new rows for that participant, and so on.
I am attaching an excel example sheet with data for the first two participants before and after.

Cheers

Suresh

Originally Posted by AlphaFrog

Try this. First test it on a copy of your data.

Sub Insert_Rows()
    Dim rngUniques As Range, cell As Range
    
    Application.ScreenUpdating = False
    
    Range("A1", Range("A" & Rows.Count).End(xlUp)).AdvancedFilter xlFilterInPlace, Unique:=True
    
    Set rngUniques = Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
    
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    
    For Each cell In rngUniques 'Loop through unique Participants
        If cell.Row > 2 Then
            cell.Resize(4).EntireRow.Insert xlShiftDown                                     'Insert 4 rows
            cell.Offset(-4, 0).Resize(4, 1).Value = cell.Offset(-5, 0).Value                'Copy column A (Participant) values
            cell.Offset(-4, 2).Resize(4, 4).Value = cell.Offset(-5, 2).Resize(1, 4).Value   'Copy columns C:F (Vars) values
        End If
    Next cell
    
    Application.ScreenUpdating = True
    
End Sub

Thanks! I tried it on a sample dataset, but it worked only for the first unique participant. It did not insert and copy for the next one. Your help would be greatly appreciated!

Correction. It worked for all participants except the last one. I think I will take care of that manually! Thanks again for your help, alphafrog

perfect! Worked like a charm Thanks again!