Layout list by VBA

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.

https://i.imgur.com/cXzWEvn.png


Thanks for your try and effort .

Try this

Code:

---

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

---

@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

https://i.ibb.co/3rHWWhM/Untitled.png

Code:

---

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

---