根据工作表名称自动将电子邮件发送给各个收件人

Question

我有一个大型报告，我必须对其进行分析，然后根据报告中的数据向个人发送电子邮件。我创建了一个宏，该宏使我可以将所需的数据拆分为工作簿中的单独工作表，以便根据应将数据通过电子邮件发送给谁来命名工作表。

我正在努力寻找如何使下一步自动化的方法，以便根据工作表的标题（人名而不是电子邮件地址）向该人发送电子邮件。

当前，我的解决方法是另一个宏，该宏将所有不同的工作表另存为单独的工作簿，但是仍然需要我手动发送带有附件的电子邮件。将所有工作表另存为单独的文件后，也许有一种更简便的自动化方法？

Sub parse_data()

    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer

    vcol = 5
    Set ws = sheets("Master")
    lr = ws.Cells(ws.rows.count, vcol).End(xlUp).row
    title = "A1:W1"
    titlerow = ws.Range(title).Cells(1).row
    icol = ws.Columns.count
    ws.Cells(1, icol) = "Unique"

    For i = 2 To lr
        On Error Resume Next
        If ws.Cells(i, vcol) <> "" _
        And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
            ws.Cells(ws.rows.count, icol).End(xlUp).offset(1) = ws.Cells(i, vcol)
        End If
    Next

    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).clear

    For i = 2 To UBound(myarr)
        ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""

        If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
            sheets.Add(after:=Worksheets(Worksheets.count)).name = myarr(i) & ""
        Else
            sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.count)
        End If

        ws.Range("A" & titlerow & ":A" & lr).EntireRow.copy sheets(myarr(i) & "").Range("A1")
        sheets(myarr(i) & "").Columns.AutoFit
    Next

    ws.AutoFilterMode = False
    ws.Activate

End Sub

Sub Splitbook()

    'Split worksheets into seperate saved files'

    Dim xPath As String
    xPath = ActiveWorkbook.path

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    For Each xWs In ThisWorkbook.sheets
        xWs.copy
        ActiveWorkbook.SaveAs filename:=xPath & "\" & xWs.name & ".xlsx"
        ActiveWorkbook.Close False
    Next

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub

我们非常感谢您的协助。预先感谢！