Copy and Paste multiple cells with VBA

Question

I'm trying to automate a macro in an Excel Worksheet. I have a big table on the first worksheet with a variable number of rows, and I need to create a number of "plates" (group of 5 rows with certain data) for each row of the main worksheet (posted in the attached image). The plates need to be displayed as in the screenshot in order to be exported in a .pdf file (2 on the same level until the last one)

This is the code I came up to using macro recording and other macro found around and already working for me (pdf printing):

Sheets("Summary").Select
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
first_row = "A2"
sec_row = "F2"
For i = 1 To lastRow

Sheets("Foglio1").Select
Range("S3:V7").Select
Selection.Copy
Range("first_row:first_row+4").Select
ActiveSheet.Paste
Range("sec_row:sec_row+4").Select
ActiveSheet.Paste

i = i + 2
Next

After this I have a code part where I export the selected area as pdf (easy and is working).

Answer 1

Assuming your summary sheet is like this

then try

Option Explicit

Sub CreatePDF()

    Dim wb As Workbook, ws As Worksheet, wsPDF As Worksheet
    Dim iLastRow As Long, ar(1 To 5, 1 To 1), rng As Range
    Dim i As Long, r As Long, c As Integer, k As Integer
   
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Summary")
    Set wsPDF = wb.Sheets("Foglio1")
    'wsPDF.Cells.Clear

    ' fixed
    ar(1, 1) = "Factory s.r.l."
    ar(2, 1) = "Ph. +39 0000 00000"
    ar(3, 1) = "Web www.website.net"
   
    iLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    r = 2 ' start row
    c = 1 ' column A
    For i = 2 To iLastRow
        ar(4, 1) = "JOB " & ws.Cells(i, "A")
        ar(5, 1) = "ORDER " & ws.Cells(i, "B")
       
        ' fill plate
        Set rng = wsPDF.Cells(r, c).Resize(5, 1)
        rng.Value2 = ar
       
        ' merge cells
        For k = 1 To 5
            With rng.Cells(k, 1).Resize(1, 4)
                .Merge
                .HorizontalAlignment = xlCenter
                .Font.Bold = True
            End With
        Next
        
        ' move to next plate
        If i Mod 2 = 0 Then
            c = 6 ' column F
        Else
            c = 1 ' column A
            r = r + 6
        End If
    Next
    MsgBox "Done"
End Sub