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
Const CardsPerRow = 2
Const RowsPerPage = 5
Const CardRowGap = 4
Const CardColumnGap = 4
PDFoutputFile = ThisWorkbook.Path & "\All cards with 10 cards per page.pdf"
Application.ScreenUpdating = False
With Worksheets("Cards")
Set cardRange = Worksheets("Cards").Range("A2:B9")
.Select
gridlines = ActiveWindow.DisplayGridlines
ActiveWindow.DisplayGridlines = False
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)
Worksheets("Cards").Range("B2").Value = .Cells(r, "A").Value
cardRange.Copy
With cardRange.Worksheet
.Pictures.Paste
Set picShape = .Shapes(.Shapes.Count)
End With
Add_Card_Picture picShape, PDFsheet, picPositionTop, picPositionLeft
n = n + 1
If n Mod CardsPerRow = 0 Then
picPositionTop = picPositionTop + picShape.Width + CardRowGap
picPositionLeft = 0
Else
picPositionLeft = picPositionLeft + picShape.Height + CardColumnGap
End If
If n Mod CardsPerRow * RowsPerPage = 0 Then
Set pageBreakCell = GetCellByPos(PDFsheet, 0, picPositionTop)
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
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
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
picShape.Cut
With destSheet
.Select
.Paste
Set picShape = .Shapes(.Shapes.Count)
End With
With picShape
picWidth = .Width
picHeight = .Height
.Top = .Width
.Left = .Height
.LockAspectRatio = msoTrue
.Rotation = 90
.Top = picPositionTop
.Left = picPositionLeft
.IncrementTop (picWidth - picHeight) / 2
If picPositionLeft > 0 Then .IncrementLeft (picHeight - picWidth) / 2
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