Trying to duplicate headers in a new row, everytime the date column changes-CodePudding

I need to find the best way to duplicate the headers row into a new header everytime the "Game date" column changes. For this week there are 2 games on Saturday and the rest of them are for Sunday, in this case I'll need the headers to duplicate just once. But if there are other dates, it must duplicate accordingly.

The dataframe was built with Python pandas, but it needs to be opened in excel, therefore I could change the code in Python or I can try to add some VBA to the excel sheet.

Output:

Game Date   Game Time   Visit   Home    Roof
Saturday, January 7, 2023   1/7/2023 13:30  Kansas City Las Vegas   Fixed
Saturday, January 7, 2023   1/7/2023 17:15  Tennessee   Jacksonville    Open
Sunday, January 8, 2023 1/8/2023 9:00   Tampa Bay   Atlanta Retractable
Sunday, January 8, 2023 1/8/2023 9:00   New England Buffalo Open
Sunday, January 8, 2023 1/8/2023 9:00   Minnesota   Chicago Open
Sunday, January 8, 2023 1/8/2023 9:00   Baltimore   Cincinnati  Open

Desired output:

Game Date   Game Time   Visit   Home    Roof
Saturday, January 7, 2023   1/7/2023 13:30  Kansas City Las Vegas   Fixed
Saturday, January 7, 2023   1/7/2023 17:15  Tennessee   Jacksonville    Open
Game Date   Game Time   Visit   Home    Roof
Sunday, January 8, 2023 1/8/2023 9:00   Tampa Bay   Atlanta Retractable
Sunday, January 8, 2023 1/8/2023 9:00   New England Buffalo Open
Sunday, January 8, 2023 1/8/2023 9:00   Minnesota   Chicago Open
Sunday, January 8, 2023 1/8/2023 9:00   Baltimore   Cincinnati  Open
Sunday, January 8, 2023 1/8/2023 9:00   Los Angeles Denver  Open
Sunday, January 8, 2023 1/8/2023 9:00   Detroit Green Bay   Open

This is what I have so far :

Sub InsertHeaderRow()

    Dim cell As Range
    
    For Each cell In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    
    If cell.Value <> cell.Offset(1, 0).Value Then
    
    Rows(1).Copy
    cell.Offset(1, 0).Insert Shift:=xlDown
    
    End If
    
    Next cell

End Sub

This creates a new row with the correct info, but it places the new row in the wrong place.

CodePudding user response：

if you don't mind using a helper column just a the right of your data, try this:

Option Explicit

Sub InsertHeaders()

    With Worksheets("Your Worksheet actual name")
        With .Range(.Cells(1, .Columns.Count).End(xlToLeft), .Cells(.Rows.Count, 1).End(xlUp))
            If .Rows.Count > 3 Then
                With .Resize(.Rows.Count - 2, 1).Offset(2, .Columns.Count)
                    .FormulaR1C1 = "=IF(RC[-5]<>R[-1]C[-5],1,"""")"
                    .Value = .Value
                End With
                
                    With .Resize(, .Columns.Count   1)
                        .AutoFilter field:=.Columns.Count, Criteria1:="1"
                        With .Resize(.Rows.Count - 1).Offset(1)
                            If Application.Subtotal(103, .Resize(, 1)) > 1 Then
                                Dim headersRng As Range
                                    Set headersRng = .Resize(1).Offset(-1)
                                        With .SpecialCells(XlCellType.xlCellTypeVisible)
                                            .Parent.AutoFilterMode = False
                                            Dim iArea As Long
                                                For iArea = .Areas.Count To 1 Step -1
                                                    headersRng.Copy
                                                    .Areas(iArea).Rows(1).Insert Shift:=xlDown
                                                Next
                                        End With
                            End If
                        End With
                    End With
                    
                    .Resize(.Rows.Count - 2, 1).Offset(2, .Columns.Count).ClearContents
            End If
        End With
    End With

End Sub

CodePudding user response：

Duplicate Header Row

Sub DuplicateHeaderRow()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1") ' adjust!
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion ' table
    
    Dim hrg As Range: Set hrg = rg.Rows(1) ' header
    Dim drg As Range: Set drg = rg.Resize(rg.Rows.Count - 1).Offset(1) ' data
    
    Dim durg As Range, dCell As Range, c As Long, IsNotFirst As Boolean
    
    For Each dCell In drg.Columns(1).Cells
        If IsNotFirst Then
            If dCell.Value <> dCell.Offset(-1).Value Then
                If durg Is Nothing Then
                    Set durg = dCell
                Else
                    c = (c   1) Mod 2
                    Set durg = Union(durg, dCell.Offset(, c))
                End If
            End If
        Else
            IsNotFirst = True
        End If
    Next dCell
    
    If Not durg Is Nothing Then
        durg.EntireRow.Insert xlShiftDown
        hrg.Copy Intersect(durg.EntireRow.Offset(-1), drg)
    End If
 
End Sub