[發問] EXCEL 篩選後附加電郵

missbb

各位, 我有一個EXCEL VBA CODE, 是成功將EXCEL篩選後轉為PDF附加電郵. 現在不想轉PDF而直按用EXCEL附加電郵. 求指教.[code]Sub input_pdf_6()
' Sub finalpdf_7()
'send excel , one excel for one shop only


    Dim xPath As String
    xPath = Application.ActiveWorkbook.Path
    Set D = CreateObject("Scripting.Dictionary")

    With Worksheets("attendance report")
        For Each A In .Range(.[d6], .[d6].End(xlDown))
            D(A.Value) = ""         'no repeat shop
        Next

            f = InputBox("input report YYMM, EG : 201508")
                If f = "" Then Exit Sub
   
        
Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$5"
        .PrintTitleColumns = ""
    End With
   
        
        For Each ky In D.KEYS
             .Range("d6").AutoFilter Field:=4, Criteria1:=ky
     
        If Dir(xPath & "\" & ky & "_" & f & ".pdf") <> "" Then Kill xPath & "\" & ky & "_" & f & ".xlxs" '同名檔案刪除
        .ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
            xPath & "\" & ky & "_" & f & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=False


    Dim Mail_Object, Mail_Single As Variant
    Dim contact As String
        contact = "xxx@gmail.com"
            Email_Subject = ky & "_" & f & "_" & "monthly report checking"
            Email_Cc = ""
            Email_Bcc = ""
            Email_Body = "" & Worksheets("email message").Range("b2")


        Set Mail_Object = CreateObject("Outlook.Application")
        Set Mail_Single = Mail_Object.CreateItem(o)

        With Mail_Single
            .Subject = Email_Subject
            .to = Email_Send_To
            .Cc = Email_Cc
            .Bcc = Email_Bcc
            .Body = Email_Body
            .Attachments.Add (xPath & "\" & ky & "_" & f & ".xlxs")
            .Display
        

        End With
             Next
        If .FilterMode = True Then .ShowAllData

    End With

End Sub


EXCLE電郵.zip (23.42 KB)

下載次數: 5

2020-4-27 19:43

GBKEE

回復 1# missbb


參考     http://forum.twbts.com/thread-22512-1-1.html

1. fds = Application.GetOpenFilename("Excel Files (*.xlsm;*.xlsx), *.xlsm;*.xlsx", , , , True)
   
2.          If IsArray(fds) Then
   
3.             For i = 1 To UBound(fds)
   
4.             .Attachments.Add fds(i)
   
5.            Next
   
6.         End If

複製代碼