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.

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


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 (http://www.vbaexpress.com/forum/member.php?9803-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

[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