export certain worksheets using a userform - excel

Question

I would like to make exports based on the boxes I checked
therefore with a lot of help I build the following code
Private Sub CommandButton1_Click()
Dim xSht As Worksheet, xFileDlg As FileDialog, xFolder As String, xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object, xEmailObj As Object, xUsedRng As Range, xArrShetts As Variant
Dim xPDFNameAddress As String, xStr As String, rngExp As Range, lastRng As Range
xArrShetts = sheetsArr(Me) 'do not forget the keep the sheetsArr function...
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
Set lastRng = xSht.Range("A" & xSht.Rows.Count).End(xlUp) 'determine the last cell in A:A
Set rngExp = xSht.Range(lastRng.Offset(-26), lastRng.Offset(, 7)) 'create the range to be exported as pdf
With xSht.PageSetup
.PaperSize = xlPaperA4
.PrintArea = rngExp.Address(0, 0)
.Orientation = xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
rngExp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard, IgnorePrintAreas:=False 'export the range, not the sheet
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
Private Sub CommandButton2_Click()
Unload basicUserform
End Sub
the problem is when I run the code no attachments show up or can be found in the destination map I choose earlier.
I also put the file here so you can see for yourself.:
https://easyupload.io/ufnmvr
I appreciate your help and time!

Answer 1

Added a check for valid range of 27 or more rows otherwise lastRng.Offset(-26) will fail and because On Error Resume Next was not cancelled with On Error Goto 0 it won't raise an error.
Private Sub CommandButton1_Click()
Dim xSht As Worksheet, xFileDlg As FileDialog
Dim xFolder As String, xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object, xEmailObj As Object
Dim xUsedRng As Range, xArrShetts As Variant
Dim xPDFNameAddress As String, xStr As String
Dim rngExp As Range, lastRng As Range
xArrShetts = sheetsArr(Me) 'do not forget the keep the sheetsArr function...
If UBound(xArrShetts) < 0 Then
MsgBox "No sheets selected", vbExclamation
Exit Sub
End If
' check sheets exist
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
Exit Sub
End If
On Error GoTo 0
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 filename 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
'determine the last cell in A:A
Set lastRng = xSht.Range("A" & xSht.Rows.Count).End(xlUp)
If lastRng.Row < 27 Then
MsgBox "Incorrect Start Row " & lastRng.Row, _
vbCritical, "ERROR on " & xSht.Name
Exit Sub
End If
'create the range to be exported as pdf
Set rngExp = xSht.Range(lastRng.Offset(-26), lastRng.Offset(, 7))
With xSht.PageSetup
.PaperSize = xlPaperA4
.PrintArea = rngExp.Address(0, 0)
.Orientation = xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
'export the range, not the sheet
rngExp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, _
Quality:=xlQualityStandard, IgnorePrintAreas:=False
xArrShetts(I) = xStr
Else
' no file created
xArrShetts(I) = ""
End If
Next
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.To = ""
.cc = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
If Len(xArrShetts(I)) > 0 Then
.Attachments.Add xArrShetts(I)
End If
Next
.Display ' or ' Send
End With
End Sub