Layout list by VBA

[parscon]

Hi eveyone i need your help regarding This excel sheet


On Sheet1 i have our stok list and page layout is A5 and want each page have only the same shelfs codes, (if it is going more than on epage will do the same) shelf codes are in column D.
when run VBA code it must create 2 row in top of each page and in fist row put shelf code in column A and also copy the first row in sheet2 to sheet1 in second empty row.
you can see sample picture.



Note : if we can add border for cells and column for each page will be great.




Thanks for your try and effort .

[Paul_Hossler]

Try this

Option Explicit


Sub Reformat()
    Dim aryColD() As String
    Dim cntColD As Long, i As Long, rowLast As Long
    
    Application.ScreenUpdating = False
    
    With Worksheets("Sheet1")
    
        .ResetAllPageBreaks
        
        rowLast = .Cells(.Rows.Count, 1).End(xlUp).Row
    
        cntColD = 1
        ReDim Preserve aryColD(1 To cntColD)
        aryColD(cntColD) = 1
        
        For i = 2 To rowLast - 1
            If .Cells(i, 4).Value <> .Cells(i + 1, 4).Value Then
                cntColD = cntColD + 1
                ReDim Preserve aryColD(1 To cntColD)
                aryColD(cntColD) = i + 1
            End If
        Next i


        For i = UBound(aryColD) To LBound(aryColD) Step -1
            Application.StatusBar = "Processing row " & i
            Worksheets("Sheet2").Rows(1).Copy
            .Rows(aryColD(i)).Insert Shift:=xlDown
            
            .Rows(aryColD(i)).Insert Shift:=xlDown
            .Cells(aryColD(i), 1).Value = .Cells(aryColD(i) + 2, 4).Value
            .Cells(aryColD(i), 1).Font.Bold = True
            If aryColD(i) > 1 Then .HPageBreaks.Add Before:=.Rows(aryColD(i))
        Next i
    End With


    Application.StatusBar = False
    Application.ScreenUpdating = True
    
    MsgBox "Done"


End Sub

[parscon]

@Paul_Hossler You saved me ! really appriciate for your great help . Good Job and thanks for your effort and time ! .

Just possible add border to cell and column excep the first row

[Paul_Hossler]

Option Explicit


Sub Reformat()
    Dim aryColD() As String
    Dim cntColD As Long, i As Long, rowLast As Long, rowLastInBlock As Long
    
    Application.ScreenUpdating = False
    
    With Worksheets("Sheet1")
    
        .ResetAllPageBreaks
        
        rowLast = .Cells(.Rows.Count, 1).End(xlUp).Row
    
        cntColD = 1
        ReDim Preserve aryColD(1 To cntColD)
        aryColD(cntColD) = 1
        
        For i = 2 To rowLast - 1
            If .Cells(i, 4).Value <> .Cells(i + 1, 4).Value Then
                cntColD = cntColD + 1
                ReDim Preserve aryColD(1 To cntColD)
                aryColD(cntColD) = i + 1
            End If
        Next i


        For i = UBound(aryColD) To LBound(aryColD) Step -1
            Application.StatusBar = "Processing row " & i
            Worksheets("Sheet2").Rows(1).Copy
            .Rows(aryColD(i)).Insert Shift:=xlDown
            
            .Rows(aryColD(i)).Insert Shift:=xlDown
            .Cells(aryColD(i), 1).Value = .Cells(aryColD(i) + 2, 4).Value
            .Cells(aryColD(i), 1).Font.Bold = True
            
            rowLastInBlock = .Cells(aryColD(i), 1).End(xlDown).Row
            
            With .Cells(aryColD(i) + 1, 1).Resize(rowLastInBlock - aryColD(i), 7).Borders
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            
            If aryColD(i) > 1 Then .HPageBreaks.Add Before:=.Rows(aryColD(i))
        Next i
    End With


    Application.StatusBar = False
    Application.ScreenUpdating = True
    
    MsgBox "Done"


End Sub