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

Excel根据工作表名称发送电子邮件

1 个答案: