[發問] 1活頁簿內以SHEET名稱配對電郵地址

missbb

大大, 下列是一個可以發送電郵附件的程式, 想加入一個WORKSHEETS("EMAIL"), 內A欄是SHEET NAME, B欄是電郵地址, 如果SHEET NAME = A欄內SHEET NAME, 則下列TO 的EMAIL ADDRESS取B欄, 但有多張SHEETS :,

1. Sub saveoneshop_email_3()
   
2. 
   
3. Dim xPath As String
   
4. Dim F As String
   
5. Dim Sheetname As String
   
6. Dim savesheet As Object
   
7. 
   
8. Application.ScreenUpdating = False
   
9. Application.DisplayAlerts = False
   
10. xPath = Application.ActiveWorkbook.Path
    
11. 
    
12. F = InputBox
    
13.     If F = "" Then Exit Sub
    
14. Sheetname = InputBox
    
15. If Sheetname = "" Then Exit Sub
    
16.     Set savesheet = ActiveWorkbook.Worksheets(Sheetname)
    
17.     savesheet.Copy
    
18.     Set savesheet = ActiveWorkbook
    
19.     savesheet.SaveAs Filename:=xPath & "\" & Sheetname & "_" & F & ".xlsx"
    
20. 
    
21.     Dim Mail_Object, Mail_Single As Variant
    
22.     Dim contact As String
    
23.     contact = "Sammisml@wilsoncomm.com.hk"
    
24.     Email_Subject = Sheetname & "_" & F & "表"
    
25.     Email_Cc = ""
    
26.     Email_Bcc = ""
    
27.     Email_Body = "XX"
    
28. 
    
29.         Set Mail_Object = CreateObject("Outlook.Application")
    
30.         Set Mail_Single = Mail_Object.CreateItem(o)
    
31. 
    
32. With Mail_Single
    
33.      .Subject = Email_Subject
    
34.     .To = Email_Send_To
    
35.     .CC = Email_Cc
    
36.     .BCC = Email_Bcc
    
37.     .Body = Email_Body
    
38.     .Attachments.Add (xPath & "\" & Sheetname & "_" & F & ".xlsx")
    
39.     .Display
    
40.     '.send
    
41. 
    
42. End With
    
43. savesheet.Close
    
44. 
    
45. Application.DisplayAlerts = True
    
46. Application.ScreenUpdating = True
    
47. End Sub

複製代碼

missbb

有大大可以賜教嗎?:D