Question

我目前有一个代码，可以根据特定于单元格B2中文本的信息将Excel工作表保存在PDF中，然后将PDF附加到电子邮件中并通过电子邮件发送给特定用户。

我不确定如何将宏添加到当前代码中以使B2中的单元格下载数据验证列表，然后重复宏以向下一个人发送特定于他们的电子邮件。

这是我必须保存pdf然后发送电子邮件的当前代码：

 Sub AttachActiveSheetPDF()
 Dim IsCreated As Boolean
 Dim i As Long
 Dim PdfFile As String, Title As String
 Dim OutlApp As Object


 Title = Range("A1")

 PdfFile = ActiveWorkbook.FullName
 i = InStrRev(PdfFile, ".")
 If i > 1 Then PdfFile = Left(PdfFile, i - 1)
 PdfFile = Range("G5") & "_" & ActiveSheet.Name & ".pdf"

 With ActiveSheet
 .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
 End With

 On Error Resume Next
 Set OutlApp = GetObject(, "Outlook.Application")
 If Err Then
 Set OutlApp = CreateObject("Outlook.Application")
 IsCreated = True
 End If
 OutlApp.Visible = True
 On Error GoTo 0

 With OutlApp.CreateItem(0)

 .Subject = Title
 .To = Range("B4")
 .CC = Range("G3")
 .Body = "Hello " & Range("G5") & "," & vbLf & vbLf _
 & "Your Summary is attached. If you have any further questions about your selections, please call 1-800-XXX-XXXX." & vbLf & vbLf _
 & "Best Regards," & vbLf _
 & Application.UserName & vbLf _
 & "Implementation Specialist" & vbLf & vbLf
 .Attachments.Add PdfFile

 On Error Resume Next
 .Send
 Application.Visible = True
 If Err Then
 MsgBox "E-mail was not sent", vbExclamation
 Else
 MsgBox "E-mail successfully sent", vbInformation
 End If
 On Error GoTo 0

 End With

 ' Delete PDF file
 Kill PdfFile

 ' Quit Outlook if it was created by this code
 If IsCreated Then OutlApp.Quit

 ' Release the memory of object variable
 Set OutlApp = Nothing

 End Sub

Answer 1

我很快写了一个例子来展示如何遍历数据验证列表。

Sub Sample()
    Dim ws As Worksheet
    Dim acell As Range, DataValCell As Range, tmpRng As Range
    Dim s As String
    Dim MyAr As Variant
    Dim i As Long

    Set ws = Sheet1 '<~~> Change this to the relevant sheet

    With ws
        Set DataValCell = .Range("B2")

        '~~> Handles =NamedRange or =$O$17:$O$18
        If Left(DataValCell.Validation.Formula1, 1) = "=" Then
            s = Mid(DataValCell.Validation.Formula1, 2)
            Set tmpRng = .Range(s)
        Else '~~> Handles aaa,bbb,ccc,ddd
            s = DataValCell.Validation.Formula1
        End If

        If Not tmpRng Is Nothing Then '~~> Handles =NamedRange or =$O$17:$O$18
            For Each acell In tmpRng.Cells
                Debug.Print acell.Value
                '~~> this is where you loop through the DV List
            Next
        Else '~~> Handles aaa,bbb,ccc,ddd
            MyAr = Split(s, ",")

            For i = LBound(MyAr) To UBound(MyAr)
                Debug.Print MyAr(i)
                '~~> this is where you loop through the DV List
            Next i
        End If
    End With
End Sub

创建循环以关闭单元格然后重复宏代码

1 个答案: