Excel根據工作表名稱發送電子郵件

Question

我創建了一個宏，該宏將主工作表拆分為不同的選項卡，並重命名了這些選項卡。 我想通過將選項卡名稱與包含電子郵件地址的列表進行匹配，將選項卡通過電子郵件發送給其他人。

我現在所擁有的是：

Sub Split_To_Workbook_and_Email_with_Body()
'Working in 2013/2016
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String
    Dim myOutlook As Object
    Dim myMailItem As Object
    Dim mySubject As String
    Dim myto As String
    Dim myPath As String
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    'Prompt for Email Subject

    Set otlApp = CreateObject("Outlook.Application")
    'mySubject = InputBox("Subject for Email")'this shows a dialog where you can enter the email subject (right now it is hard coded)

    'myto = Application.VLOOKUP(SheetId, Sheet1!A3:B48, 2, FALSE)
    'myto = Application.VLookup(SheetId, Sheet1!A3:B48, 2, range_lookup)


    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ActiveWorkbook
    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = "Z:\user\report" & Sourcewb.Name & " " & DateString
    MkDir FolderName
    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets
        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy
            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook
            'Determine the Excel version and file extension/format
            With Destwb
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007-2016
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                End If
            End With
            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If
            'Save the new workbook, email it, and close it
            Set otlNewMail = otlApp.CreateItem(olMailItem)
            With Destwb
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                        FileFormat:=FileFormatNum
            End With
            myPath = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
            idkfile = "C:\Users\UniaHa\Desktop\Testing.txt"
            With Destwb
                .Close False
            End With
            With otlNewMail
                '.Subject = mySubject
                .to = test@test.ca
                .Subject = "Diversion Report"
                .Body = "Dear customer," & vbNewLine & vbNewLine & _
    "This is your  report please..... blah blah" & _
    vbNewLine & vbNewLine & "Regards," & vbNewLine & vbNewLine & "Sender Name"
                .Attachments.Add myPath
                .Attachments.Add idkfile
                .Display
            End With

            Set otlNewMail = Nothing
        End If
GoToNextSheet:
    Next sh
    MsgBox "You can find the files in " & FolderName
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

Answer 1

對於您的vlookup，您可以嘗試以下操作：

On Error Resume Next

for each sht in activeworkbook.worksheets

    err.clear
    sEmailTo = Application.worksheetfunction.VLOOKUP(sh.name, Sheet1!A3:B48, 2, FALSE)

    if err<>0 and semailto like "*@*" Then
        'send your email
    end if

next sht

On Error goto 0