Check which worksheets to export as pdf

Question

I am a beginner in Excel VBA but I would like to create a file where I can select certain worksheets by means of a userform with checkboxes. In principle, it is then intended that only the check boxes where the value is true should be exported.

Below I have 2 codes that work well separately from each other but I have not yet been able to get them to work together.

Note: both codes come from the internet.

If possible I would like to write a loop to keep the overview.

the code to export sheets as pdf and put them in a outlook

Sub Saveaspdfandsend1()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xArrShetts As Variant
Dim xPDFNameAddress As String
Dim xStr As String
xArrShetts = Array("test", "Sheet1", "Sheet2") 'Enter the sheet names you will send as pdf files enclosed with quotation marks and separate them with comma. Make sure there is no special characters such as \/:"*<>| in the file name.

For I = 0 To UBound(xArrShetts)
On Error Resume Next
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
Exit Sub
End If
Next


Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
'Check if file already exist
xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
vbYesNo + vbQuestion, "File Exists")
If xYesorNo <> vbYes Then Exit Sub
For I = 0 To UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))

xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
While Not (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Wend
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard
Else

End If
xArrShetts(I) = xStr
Next

'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
.Attachments.Add xArrShetts(I)
Next
If DisplayEmail = False Then
'.Send
End If
End With
End Sub

the other code i tried I can see which checkbox is checked unfortunately I can't rewrite it so only the checked boxes will be exported to pdf.

Private Sub CommandButton100_Click()

For i = 100 To 113

If UserForm2.Controls("CheckBox" & i).Value = True Then
a = a + 1
End If

Next i

k = 1

For i = 100 To 113

If UserForm2.Controls("CheckBox" & i).Value = True And a = 1 Then
    b = UserForm2.Controls("CheckBox" & i).Caption & "."
ElseIf UserForm2.Controls("CheckBox" & i).Value = True And k <> a Then
    b = b & UserForm2.Controls("CheckBox" & i).Caption & ", "
    k = k + 1
ElseIf UserForm2.Controls("CheckBox" & i).Value = True And k = a Then
    b = b & "and " & UserForm2.Controls("CheckBox" & i).Caption & "."
End If

Next i

MsgBox ("You have selected " & b)

End Sub

Can someone help me please I am struggling for some time now?

user_2233308 · Answer

Please, try the next function:

Private Function sheetsArr(uF As UserForm) As Variant
  Dim c As MSForms.Control, strCBX As String, arrSh
  For Each c In uF.Controls
        If TypeOf c Is MSForms.CheckBox Then
            If c.value = True Then strCBX = strCBX & "," & c.Caption
        End If
  Next
  sheetsArr = Split(Mid(strCBX, 2), ",") 'Mid(strCBX, 2) eliminates the first string character (",")
End Function

It will return an array composed from the ticked check boxes caption.

It can be used demonstratively, in this way:

Sub testSheetsArrFunction()
    Debug.Print Join(sheetsArr(UserForm2), ",")
End Sub

The above code will return in Immediate Window a string containing the checked check boxes caption (separated by comma). It may be run from a standard module, too. Of course, the function must be copied in that module. And the form to be loaded, having some check boxes ticked.

Now, you have to change a single code line in your (working) code:

Replace:

xArrShetts = Array("test", "Sheet1", "Sheet2")

with:

xArrShetts = sheetsArr(UserForm2)

It should use the array built in the above function. Of course the function have to be copied in the module where to be called. If placed in the form code module, it can be simple called as:

xArrShetts = sheetsArr(Me)

Edited:

You should only paste the next code in the form code module and show the form:

Private Sub CommandButton1_Click()

Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xArrShetts As Variant
Dim xPDFNameAddress As String
Dim xStr As String
'xArrShetts = Array("test", "Sheet1", "Sheet2") 'Enter the sheet names you will send as pdf files enclosed with quotation marks and separate them with comma. Make sure there is no special characters such as \/:"*<>| in the file name.
xArrShetts = sheetsArr(Me)

For I = 0 To UBound(xArrShetts)
    On Error Resume Next
    Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
    If xSht.Name <> xArrShetts(I) Then
        MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
    Exit Sub
    End If
Next


Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
    xFolder = xFileDlg.SelectedItems(1)
Else
    MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
    Exit Sub
End If
'Check if file already exist
xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
vbYesNo + vbQuestion, "File Exists")
If xYesorNo <> vbYes Then Exit Sub
For I = 0 To UBound(xArrShetts)
    Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
    
    xStr = xFolder & "\" & xSht.Name & ".pdf"
    xNum = 1
    While Not (Dir(xStr, vbDirectory) = vbNullString)
        xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
        xNum = xNum + 1
    Wend
    Set xUsedRng = xSht.UsedRange
    If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
        xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard
    End If
    xArrShetts(I) = xStr
Next

'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
    .Display
    .To = ""
    .CC = ""
    .Subject = "????"
    For I = 0 To UBound(xArrShetts)
        .Attachments.Add xArrShetts(I)
    Next
    If DisplayEmail = False Then
        '.Send
    End If
End With
End Sub

Private Function sheetsArr(uF As UserForm) As Variant
  Dim c As MSForms.Control, strCBX As String, arrSh
  For Each c In uF.Controls
        If TypeOf c Is MSForms.CheckBox Then
            If c.Value = True Then strCBX = strCBX & "," & c.Caption
        End If
  Next
  sheetsArr = Split(Mid(strCBX, 2), ",") 'Mid(strCBX, 2) eliminates the first string character (",")
End Function

Check which worksheets to export as pdf

1 Answers