问如何筛选主工作簿以表而不是文件的形式发送结果？
EN

Stack Overflow用户

提问于 2019-11-27 00:19:06

回答 1查看 264关注 0票数 0

我的任务是筛选主工作簿，将结果发送给各自的收件人。将位于工作簿中的电子邮件的收件人和正文。

我必须发送50多封电子邮件，结果在表格格式，超过50个不同的收件人。

Option Explicit

Sub split()

    Dim wswb As String
    Dim wssh As String

    Dim vColumn As Variant

    Dim i As Integer
    Dim vcounter As Variant
    Dim vfilter As String

    wswb = ActiveWorkbook.Name
    wssh = ActiveSheet.Name

    vColumn = InputBox("Select Column to Filter", "Column Selection")

    Columns(vColumn).Copy
    Sheets.Add

    ActiveSheet.Name = "Working_Magic"
    Range("A1").PasteSpecial

    Columns("A").RemoveDuplicates Columns:=1, Header:=xlYes

    vcounter = Range("A" & Rows.Count).End(xlUp).Row

    For i = 2 To vcounter
        vfilter = Sheets("Working_Magic").Cells(i, 1)
        Sheets(wssh).Activate
        ActiveSheet.Columns.AutoFilter field:=Columns(vColumn).Column, Criteria1:=vfilter
        Cells.Copy
        Workbooks.Add
      
        Range("A1").PasteSpecial
        If vfilter <> "" Then
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\DSAttachments_to_email\" & vfilter
        Else
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\DSAttachments_to_email\_Empty"
        End If
        ActiveWorkbook.Close
        Workbooks(wswb).Activate
    
    Next i
    Sheets("Working_Magic").Delete
    
End Sub

我不需要将附件保存在上述代码所示的文件夹中，而是将报告发送给所有相应的收件人。

outlook

excel

vba

回答 1

Stack Overflow用户

回答已采纳

发布于 2019-11-27 08:55:03

我会使用两种方法中的一种，将范围转换为HTML表并将其插入到电子邮件中，或者使用SendKeys '^c', true，然后使用SendKeys '^v', true。我的首选是第一个选项，代码如下：

Sub LoopThroughTable()

    Set ws = ActiveSheet

    For i = 2 To Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
        email_to = Sheet1.Cells(i, 5).Value
        email_subject = Sheet1.Cells(i, 4).Value

        folder_path = Sheet1.Cells(i, 2).Value

        Set FSO = CreateObject("Scripting.FileSystemObject")
        'Set fld = FSO.GetFolder(folder_path)
        If FSO.FolderExists(folder_path) Then
            'Nothing, folder is good
        Else
            'Just save to desktop
            folder_path = CreateObject("WScript.Shell").SpecialFolders("Desktop")
            Sheet1.Cells(i, 2).Value = folder_path
        End If

        If Right(folder_path, 1) <> "\" Then
            Sheet1.Cells(i, 2).Value = folder_path & "\"
        End If

        file_path = Sheet1.Cells(i, 2).Value & Sheet1.Cells(i, 3).Value

        sheet_name = Sheet1.Cells(i, 1).Value
        sheet_name_range = Sheet1.Cells(i, 9).Value
        Dim table_range As Range
        Dim range_string As String
        range_string = Sheet1.Cells(i, 10)
        Set table_range = Sheets(sheet_name_range).Range(range_string) 'Range("A3:C8") 'etc.

        email_body = Sheet1.Cells(i, 8).Value & "<br><br>" & ConvertRangeToHTMLTable(table_range)

        CopySheetAndSave sheet_name, file_path

        SendOutlookMessage email_to, email_subject, file_path, email_body
        ThisWorkbook.Activate
    Next i

    ws.Activate

End Sub

Sub CopySheetAndSave(ByVal sheet_name As String, ByVal full_path As String)

    SheetName = sheet_name
    FullPath = full_path

    Sheets(SheetName).Select
    Sheets(SheetName).Copy
    'ChDir "C:\Users\username\Downloads"
    Workbooks(Workbooks.Count).SaveAs Filename:=FullPath, FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
    Workbooks(Workbooks.Count).Close
End Sub


Sub SendOutlookMessage(ByVal email_to As String, ByVal email_subject As String, ByVal file_path As String, ByVal email_body As String)

    emailTo = email_to
    emailSub = email_subject
    FullPath = file_path
    HTMLBODY = email_body

    DoEvents
    Application.Wait 1

    Dim olApp As Object
    Dim olMail As Object

    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(0)
    With olMail
        .to = emailTo
        .Subject = emailSub
        .Attachments.Add (FullPath)

        .HTMLBODY = HTMLBODY
        DoEvents

        .Display
        Application.Wait 1
        .Send

    End With

    Application.Wait 1

    Set olMail = Nothing
    Set olApp = Nothing

End Sub

'Following function converts Excel range to HTML table
'Taken from https://excelsirji.com/vba-code-to-convert-excel-range-into-html-table/
Public Function ConvertRangeToHTMLTable(rInput As Range) As String
    'Declare variables
    Dim rRow As Range
    Dim rCell As Range
    Dim strReturn As String
    'Define table format and font
    strReturn = "<Table border='1' cellspacing='0' cellpadding='7' style='border-collapse:collapse;border:none'>  "
    'Loop through each row in the range
    For Each rRow In rInput.Rows
        'Start new html row
        strReturn = strReturn & " <tr align='Center'; style='height:10.00pt'> "
        For Each rCell In rRow.Cells
            'If it is row 1 then it is header row that need to be bold
            If rCell.Row = 1 Then
                strReturn = strReturn & "<td valign='Center' style='border:solid windowtext 1.0pt; padding:0cm 5.4pt 0cm 5.4pt;height:1.05pt'><b>" & rCell.Text & "</b></td>"
            Else
                strReturn = strReturn & "<td valign='Center' style='border:solid windowtext 1.0pt; padding:0cm 5.4pt 0cm 5.4pt;height:1.05pt'>" & rCell.Text & "</td>"
            End If
        Next rCell
        'End a row
        strReturn = strReturn & "</tr>"
    Next rRow
    'Close the font tag
    strReturn = strReturn & "</font></table>"
    'Return html format
    ConvertRangeToHTMLTable = strReturn
End Function