Public Sub Create_Cards_PDF()
Dim PDFoutputFile As String
Dim PDFsheet As Worksheet
Dim currentSheet As Worksheet
Dim r As Long, n As Long
Dim cardRange As Range
Dim picPositionTop As Single, picPositionLeft As Single
Dim picShape As Shape
Dim pageBreakCell As Range
Dim gridlines As Boolean
'2 cards per row x 5 rows per page gives 10 cards per page
Const CardsPerRow = 2
Const RowsPerPage = 5
'Gap between rows and columns of cards on output PDF
Const CardRowGap = 4
Const CardColumnGap = 4
PDFoutputFile = ThisWorkbook.Path & "\All cards with 10 cards per page.pdf"
Application.ScreenUpdating = False
'The single card is A2:B9 on the Cards sheet
With Worksheets("Cards")
Set cardRange = Worksheets("Cards").Range("A2:B9")
.Select
gridlines = ActiveWindow.DisplayGridlines
ActiveWindow.DisplayGridlines = False 'turn off gridlines, otherwise they appear in the PDF
End With
With ActiveWorkbook
Set currentSheet = .ActiveSheet
Set PDFsheet = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
ActiveWindow.DisplayGridlines = False
End With
picPositionTop = 0
picPositionLeft = 0
With Worksheets("Consolidated")
n = 0
r = 2
While Not IsEmpty(.Cells(r, "A").Value)
'Create a picture of the next card
Worksheets("Cards").Range("B2").Value = .Cells(r, "A").Value
cardRange.Copy
With cardRange.Worksheet
.Pictures.Paste
Set picShape = .Shapes(.Shapes.Count)
End With
'Add the picture to the PDF sheet in the correct position
Add_Card_Picture picShape, PDFsheet, picPositionTop, picPositionLeft
n = n + 1
If n Mod CardsPerRow = 0 Then
'Set top position for next card on a new row
picPositionTop = picPositionTop + picShape.Width + CardRowGap
picPositionLeft = 0
Else
'Set left position for next card on the same row
picPositionLeft = picPositionLeft + picShape.Height + CardColumnGap
End If
If n Mod CardsPerRow * RowsPerPage = 0 Then
'All cards on a page so insert page break
Set pageBreakCell = GetCellByPos(PDFsheet, 0, picPositionTop)
'Debug.Print "Page break " & pageBreakCell.EntireRow.Address
PDFsheet.HPageBreaks.Add Before:=pageBreakCell.EntireRow
picPositionTop = pageBreakCell.Top
End If
r = r + 1
Wend
End With
Application.PrintCommunication = False
With PDFsheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0.5)
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
End With
Application.PrintCommunication = True
'Save PDF sheet as a .pdf file
PDFsheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFoutputFile, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Application.DisplayAlerts = False
PDFsheet.Delete
Application.DisplayAlerts = True
Worksheets("Cards").Select
ActiveWindow.DisplayGridlines = gridlines 'restore gridlines setting
currentSheet.Select
Application.ScreenUpdating = True
MsgBox "Created " & PDFoutputFile
End Sub
Private Sub Add_Card_Picture(picShape As Shape, destSheet As Worksheet, picPositionTop As Single, picPositionLeft As Single)
Dim picWidth As Single, picHeight As Single
'Cut source card shape and paste on PDF sheet
picShape.Cut
With destSheet
.Select
.Paste
Set picShape = .Shapes(.Shapes.Count)
End With
With picShape
picWidth = .Width
picHeight = .Height
'Set shape's position away from (0,0) so that rotating it 90 degrees does not change its width and height
.Top = .Width
.Left = .Height
'Debug.Print "Before rotate top=" & .Top & ", left=" & .Left & ", width=" & .Width & ", height=" & .Height
'Rotate shape 90 degrees to put card sideways
.LockAspectRatio = msoTrue
.Rotation = 90
'Debug.Print "After rotate top=" & .Top & ", left=" & .Left & ", width=" & .Width & ", height=" & .Height
'Set shape's correct position
.Top = picPositionTop
.Left = picPositionLeft
.IncrementTop (picWidth - picHeight) / 2 'move up
If picPositionLeft > 0 Then .IncrementLeft (picHeight - picWidth) / 2 'move right
'Debug.Print "After reposition top=" & .Top & ", left=" & .Left & ", width=" & .Width & ", height=" & .Height
End With
End Sub
Private Function GetCellByPos(ws As Worksheet, x As Single, y As Single) As Range
With ws.Shapes.AddLine(x, y, x, y)
Set GetCellByPos = .TopLeftCell
.Delete
End With
End Function
,
