Insert row to separates group of data with header-CodePudding

Would anyone will be able to help me with this script please?

As it stand, this current macro separate the data once the value/text have changes and insert new row but I just cannot work it out how to include the headers once the row have been inserted.

Sub Insert Row()

Dim ws As Worksheet
Dim lr As Long
Dim i As Long

Set ws = Worksheets("Sheet1") 'the sheet with the data
lr = ws.Range("A" & Rows.Count).End(xlUp).Row 'last row with data in Column A
For i = lr - 1 To 2 Step -1
If ws.Range("A" & i).Value <> ws.Range("A" & i   1).Value Then ws.Range("A" & i   1).EntireRow.Insert
Next i

End Sub

Thank you in advanced.

CodePudding user response：

Please ignore my comment, as I just realize that it will be a different result if in column A there is a cell with the same value.

Example Data :

Expected result... (separation start in cell A16) :

Sub test()
Dim rgHdr As Range: Dim rgData As Range: Dim oFill As Range
Dim el: Dim arr: Dim cell As Range

With ActiveSheet
Set rgHdr = .Range("A1", .Range("A1").End(xlToRight))
Set rgData = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
Set oFill = rgData.End(xlDown).Offset(6, 0)
End With

Set arr = CreateObject("scripting.dictionary")
For Each cell In rgData: arr.Item(cell.Value) = 1: Next

For Each el In arr
    With rgData
        .Replace el, True, xlWhole, , False, , False, False
        Set rgR = .SpecialCells(xlConstants, xlLogical)
        .Replace True, el, xlWhole, , False, , False, False
    End With
        
    Union(rgHdr, rgR.Resize(rgR.Rows.Count, rgHdr.Columns.Count)).Copy
    oFill.PasteSpecial (xlAll)
    Set oFill = oFill.End(xlDown).Offset(2, 0)
Next

End Sub

arr variable contains unique value in column A.

then it loop to each element in arr, where it get the range for all cell in column A which value is the looped element as rgR variable.

Then it copy the union of the rgHdr and the rgRrgR.Resize(rgR.Rows.Count, rgHdr.Columns.Count), paste to oFill, set the oFill to offset, then go to the next element (the next unique value).

CodePudding user response：

Duplicate Headers

A Quick Fix

Sub InsertHeaders()

    Const FIRST_ROW As Long = 1
    Const EMPTY_ROWS As Long = 1
    
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
    Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    Dim r As Long
    
    For r = LastRow To FIRST_ROW   2 Step -1
        With ws.Cells(r, "A")
            If .Value <> .Offset(-1).Value Then
                .EntireRow.Resize(EMPTY_ROWS   1).Insert
                ws.Rows(1).Copy ws.Rows(.Row - 1)
            End If
        End With
    Next r

End Sub