vba to duplicate blocks of text

[kitkat22]

I have a spreadsheet with many blocks of rows that I need to duplicate. In column I, some cells have the number 7. I want to duplicate the entire block of rows that include the row with the 7 and all the rows with no 7 underneath it, until you get to the next row with a 7 in column I. Then I want to repeat the process for that block of rows, all the way down to the end of the sheet. If the duplicated rows could be a new color, that would be even better. I hope this is clear!

 

[kweaver]

Welcome to Mr. Excel.

Where do you want the results?

It would be helpful if you provided a sample of data and the results you expect...AND, please use XL2BB to show your sample.

 

[kitkat22]

This is the original sheet

Mini-sheet removed by moderator

 

[kitkat22]

And this is how I want it to look

Mini-sheet removed by moderator

 

[Peter_SSs]

Welcome to the MrExcel board!

Give this a try with a copy of your workbook.

Sub Duplicate_Blocks()
  Dim rA As Range
  Dim cols As Long, rws As Long
  
  Application.ScreenUpdating = False
  cols = ActiveSheet.UsedRange.Columns.Count
  For Each rA In Range("I2:I" & Range("J" & Rows.Count).End(xlUp).Row).SpecialCells(xlBlanks).Areas
      If rA.Cells(0).Value = 7 Then
        rws = rA.Rows.Count + 1
        With rA.Rows(0).EntireRow.Resize(rws, cols)
          .Copy
          .Offset(rws).Insert Shift:=xlDown
          .Offset(rws).Interior.Color = RGB(217, 217, 217)
        End With
      End If
  Next rA
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

 

[kitkat22]

Welcome to the MrExcel board!

Give this a try with a copy of your workbook.

Sub Duplicate_Blocks()
  Dim rA As Range
  Dim cols As Long, rws As Long
 
  Application.ScreenUpdating = False
  cols = ActiveSheet.UsedRange.Columns.Count
  For Each rA In Range("I2:I" & Range("J" & Rows.Count).End(xlUp).Row).SpecialCells(xlBlanks).Areas
      If rA.Cells(0).Value = 7 Then
        rws = rA.Rows.Count + 1
        With rA.Rows(0).EntireRow.Resize(rws, cols)
          .Copy
          .Offset(rws).Insert Shift:=xlDown
          .Offset(rws).Interior.Color = RGB(217, 217, 217)
        End With
      End If
  Next rA
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

This worked perfectly! Thank you so much! Would it be possible to delete my two posts with the spreadsheets and just keep my initial question and solution?

 

[Peter_SSs]

This worked perfectly! Thank you so much!

You're welcome. Glad it worked for you.

Would it be possible to delete my two posts with the spreadsheets and just keep my initial question and solution?

On this occasion I have removed the mini-sheets but for the future please ensure that your samples do not include any sensitive data.