Checkboxes and generating PDF VBA style

pasjauo

New Member
Joined
May 1, 2017
Messages
44
Hi guys

I have a problem with a code that I have gotten some help to do for a friends company.

On the front page they have checkboxes of the content of the pdf they want generated (quotation with various content) and the VBA is set to always include a front page and 2 back pages ("Front page" "xxx last page"). Now they want a 3rd back page ("last page") added, and I have succeeded. That have though lead the 3rd back page to cannibalize on the content of the checkboxes. I know the theory of what is wrong but I can't seem to find the place where i can do anything about it.

I have translated my sheet names in this code to give a better picture of what the sheets represent.

VBA Code:
Sub generatepdf()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Application.PrintCommunication = False

On Error Resume Next
Dim d() As Variant

Sheets("Front Page").Select
Client = Range("C2").Value
sh = ""
y = -1
For Each chk In ActiveSheet.CheckBoxes

If chk.Value = 1 Then
    SheetName = chk.Text
    If SheetName = "ONE IMPORT" Then
    y = y + 1
    ReDim d(y)
    d(0) = "Quote One Import"
    Sheets("Quote One Import").Activate
    With ActiveSheet.PageSetup
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = 1
End With
    ActiveSheet.UsedRange.Select
    Sheets("Quote One Import").PageSetup.CenterHorizontally = True
    sh = sh & IIf(sh = "", "", ",") & "Quote One Import"
   
    ElseIf SheetName = "TWO IMPORT" Then
    y = y + 1
    ReDim d(y)
    d(0) = "Quote Two Import"
    Sheets("Quote Two Import").Activate
    With ActiveSheet.PageSetup
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = 1
    .CenterHorizontally = True
End With
    ActiveSheet.UsedRange.Select
    sh = sh & IIf(sh = "", "", ",") & "Quote Two Import"
   
    ElseIf SheetName = "THREE IMPORT" Then
    y = y + 1
    ReDim d(y)
    d(0) = "Quote Three Import"
    Sheets("Quote Three Import").Activate
    With ActiveSheet.PageSetup
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = 1
End With
    ActiveSheet.UsedRange.Select
    Sheets("Quote Three Import").PageSetup.CenterHorizontally = True
    sh = sh & IIf(sh = "", "", ",") & "Quote Three Import"
   
    ElseIf SheetName = "ONE EXPORT" Then
    y = y + 1
    ReDim d(y)
    d(0) = "Quote One Export"
    Sheets("Quote One Export").Activate
    With ActiveSheet.PageSetup
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = 1
    .PageSetup.CenterHorizontally = True
End With
    ActiveSheet.UsedRange.Select
    sh = sh & IIf(sh = "", "", ",") & "Quote One Export"
   
    ElseIf SheetName = "TWO EXPORT" Then
    y = y + 1
    ReDim d(y)
    d(0) = "Quote Two Export"
    Sheets("Quote Two Export").Activate
    With ActiveSheet.PageSetup
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = 1
    .PageSetup.CenterHorizontally = True
End With
    ActiveSheet.UsedRange.Select
    Sheets("Quote Two Export").PageSetup.CenterHorizontally = True
    sh = sh & IIf(sh = "", "", ",") & "Quote Two Export"
   
    ElseIf SheetName = "THREE EXPORT" Then
    y = y + 1
    ReDim d(y)
    d(0) = "Quote Three Export"
    Sheets("Quote Three Export").Activate
    With ActiveSheet.PageSetup
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = 1
End With
    ActiveSheet.UsedRange.Select
    Sheets("Quote Three Export").PageSetup.CenterHorizontally = True
    sh = sh & IIf(sh = "", "", ",") & "Quote Three Export"
   
    ElseIf SheetName = "ONE CROSS" Then
    y = y + 1
    ReDim d(y)
    d(0) = "Quote One Cross"
    Sheets("Quote One Cross").Activate
    With ActiveSheet.PageSetup
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = 1
End With
    ActiveSheet.UsedRange.Select
    Sheets("Quote One Cross").PageSetup.CenterHorizontally = True
    sh = sh & IIf(sh = "", "", ",") & "Quote One Cross"
   
    ElseIf SheetName = "TWO CROSS" Then
    y = y + 1
    ReDim d(y)
    d(0) = "Quote Two Cross"
    Sheets("Quote Two Cross").Activate
    With ActiveSheet.PageSetup
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = 1
End With
    ActiveSheet.UsedRange.Select
    Sheets("Quote Two Cross").PageSetup.CenterHorizontally = True
    sh = sh & IIf(sh = "", "", ",") & "Quote Two Cross"
    End If
End If
Next
sh1 = sh
y = y + 3
ded = 2
If InStr(sh, "One") > 0 Or InStr(sh, "Two") > 0 Then
'    y = y + 1
'   ded = 2
   
  '  Sheets("AddS").Activate
   ' ActiveSheet.Range("a1:r120").Select
    'ActiveSheet.PrintArea = ActiveSheet.Range("a1:t110").Address
End If

'With Worksheets("Adds").PageSetup
'   .FitToPagesWide = 1
  '  .FitToPagesTall = False
'End With

ReDim d(y)
If sh <> "" Then
For i = 1 To UBound(d) - ded
    lens = IIf(i = 0 And InStr(sh, ",") > 0, InStr(sh, ",") - 1, IIf(InStr(sh1, ",") > 0, InStr(sh1, ",") - 1, Len(sh1)))
    st = IIf(i = 0, 1, InStr(sh1, ",") + 1)
    d(i) = Mid(sh1, 1, lens)
    sh1 = Mid(sh, InStr(sh, d(i)) + Len(d(i)) + 1)
Next
If ded = 2 Then
    d(UBound(d) - ded + 1) = "AddS"
End If



'    Sheets("AddS").PageSetup.Zoom = False
'   Sheets("AddS").PageSetup.FitToPagesWide = 1
  '  Sheets("AddS").PageSetup.FitToPagesTall = 1
   
'If sh <> "" Then
'For i = 0 To UBound(d)
'   lens = IIf(i = 0 And InStr(sh, ",") > 0, InStr(sh, ",") - 1, IIf(InStr(sh1, ",") > 0, InStr(sh1, ",") - 1, Len(sh1)))
  '  st = IIf(i = 0, 1, InStr(sh1, ",") + 1)
   ' d(i) = Mid(sh1, 1, lens)
   ' sh1 = Mid(sh, InStr(sh, d(i)) + Len(d(i)) + 1)
'Next
    
d(0) = "Front page"
d(UBound(d) - 2) = "Last page"
d(UBound(d) - 1) = "3rd last page"
d(UBound(d)) = "2nd last page"
    Sheets("Front page").Activate
    ActiveSheet.Range("a1:j70").Select
    Sheets("Front page").PageSetup.CenterHorizontally = True
    Sheets("3rd last page").Activate
    ActiveSheet.Range("a1:j70").Select
    Sheets("3rd last page").PageSetup.CenterHorizontally = True
    Sheets("2nd last page").Activate
    ActiveSheet.Range("a1:j70").Select
    Sheets("2nd last page").PageSetup.CenterHorizontally = True
    Sheets("last page").Activate
    ActiveSheet.Range("a1:j70").Select
    Sheets("last page").PageSetup.CenterHorizontally = True
'ThisWorkbook.Sheets(Array(sh)).Select

ThisWorkbook.Sheets(d).Select

Selection.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
        ThisWorkbook.Path & "\" & " " & Client & "_" & Format(Now(), "ddmmyyyy\") & ".pdf", _
          Quality:=xlQualityStandard, IncludeDocProperties:=True, _
          IgnorePrintAreas:=False, OpenAfterPublish:=True
End If
'Application.PrintCommunication = True

sh = ""
Sheets("Front page").Select

MsgBox " PDF GENERERET", vbOKOnly + vbInformation, "Succes"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
 

Some videos you may like

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).

Watch MrExcel Video

Forum statistics

Threads
1,122,364
Messages
5,595,714
Members
414,013
Latest member
tnobbs

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top