检查要导出为 pdf 的工作表

Question

我是 Excel VBA 的初学者，但我想创建一个文件，我可以在其中通过带有复选框的用户表单选择某些工作表。 原则上，只应导出值为 true 的复选框。

下面我有 2 个代码，它们彼此独立运行良好，但我还没有让它们一起工作。

注意：两个代码都来自互联网。

如果可能的话，我想写一个循环来保持概述。

将工作表导出为 pdf 并将它们放入 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

我试过的其他代码我可以看到哪个复选框被选中，不幸的是我无法重写它所以只有选中的框才会导出为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

有人可以帮助我吗我现在挣扎了一段时间？

Answer 1

请尝试下一个功能：

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

它将返回一个由勾选的复选框标题组成的数组。

它可以以这种方式进行示范使用：

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

上面的代码将在立即窗口中返回一个字符串，其中包含选中的复选框标题（用逗号分隔）。 它也可以从标准模块运行。 当然，函数必须复制到那个模块中。 和要加载的表单，勾选了一些复选框。

现在，您必须更改（工作）代码中的单个代码行：

代替：

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

和：

xArrShetts = sheetsArr(UserForm2)

它应该使用上面函数中内置的数组。 当然，该函数必须复制到要调用的模块中。 如果放在表单代码模块中，可以简单调用为：

xArrShetts = sheetsArr(Me)

编辑：

您应该只在表单代码模块中粘贴下一个代码并显示表单：

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