extract email address based on name of file attached

[howard]

I have names of various workbooks in Col A and the email address to cc on col B pertaining to the file name


I have the following code below to email and allow a user to attach a file


Based on the name file attached, I would like the code to look up the email address to cc in Col B based on the file name

 .Subject = Application.ActiveWorkbook.Name & "  -Summary Sales Report"

It would be appreciated if someone could amend my code to accommodate this

 Sub SendFiles()
    Dim lCount As Long
    Dim vFilenames As Variant
    Dim sPath As String
    Dim lFilecount As Long
    Dim sFullName As String
    sPath = "C:\Summary Sales Reports\"
    ChDrive sPath
    ChDir sPath
    vFilenames = Application.GetOpenFilename("Microsoft Excel files (*.xls),*.xls", , "Please select the file(s) to open", , True)
    If TypeName(vFilenames) = "Boolean" Then Exit Sub
    For lCount = LBound(vFilenames) To UBound(vFilenames)
        Workbooks.Open vFilenames(lCount), UpdateLinks:=False
        Application.DisplayAlerts = False
        Application.CutCopyMode = False
       Sheets(Array("summary")).Copy
        ActiveWorkbook.SaveAs Replace(vFilenames(lCount), ".xls", "") & ".summary.xls", FileFormat:=xlNormal
        vFilenames(lCount) = ActiveWorkbook.FullName
        Application.ScreenUpdating = False
        For Each sht In Sheets(Array("summary"))
        Sheets(sht.Name).UsedRange.Copy
        Sheets(sht.Name).Range("a1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Next
        Application.ScreenUpdating = True
        ActiveWorkbook.Close True
        Application.DisplayAlerts = True
        Application.CutCopyMode = True
    Next
      Mailfiles "dave.preswick@xway.com", vFilenames
    For lCount = LBound(vFilenames) To UBound(vFilenames)
Kill vFilenames(lCount)
Next
   ActiveWorkbook.Close False
End Sub

Sub Mailfiles(sMailAddress As String, vFiles As Variant)
    
    

    
    
    Dim oMailItem As Object
    Dim oOLapp As Object
    Dim lCt As Long

    Set oOLapp = CreateObject("Outlook.application")
    Set oMailItem = oOLapp.CreateItem(0)
    With oMailItem
        .To = sMailAddress
         .Subject = Application.ActiveWorkbook.Name & "  -Summary Sales Report"
         

       .body = "Attached please find summary sales per region as at " & Format(Application.EoMonth(Date, -1), "mmm yyyy") & " vs the Prior Year" & vbNewLine & vbNewLine
                  
              .body = .body & "Regards" & vbNewLine & vbNewLine
.body = .body & "Simon"

           
       
       
       
                     
              
                For lCt = LBound(vFiles) To UBound(vFiles)
            .attachments.Add CStr(vFiles(lCt))
        Next
        .Display
        Set oOLapp = Nothing
        Set oMailItem = Nothing
    End With
   
      
End Sub

 

[Worf]

The code below assumes a single attachment. Are you going to attach multiple files?

Dim wn$
Sub SendFiles()
Dim lCount As Long, sht As Worksheet, vFilenames, sPath$, lFilecount As Long, sFullName$
sPath = "C:\users\public\Summary\"      ' your path here
ChDrive sPath
ChDir sPath
wn = ThisWorkbook.Name
vFilenames = Application.GetOpenFilename("Microsoft Excel files (*.xlsm),*.xlsm", , "Please select the file(s) to open", , True)
If TypeName(vFilenames) = "Boolean" Then Exit Sub
For lCount = LBound(vFilenames) To UBound(vFilenames)
    Workbooks.Open vFilenames(lCount), UpdateLinks:=False
    Application.DisplayAlerts = False
    Application.CutCopyMode = False
    Sheets(Array("summary")).Copy
    ActiveWorkbook.SaveAs Replace(vFilenames(lCount), ".xls", "") & "_summary.xls", FileFormat:=xlNormal
    vFilenames(lCount) = ActiveWorkbook.FullName
    Application.ScreenUpdating = False
    For Each sht In Sheets(Array("summary"))
        Sheets(sht.Name).UsedRange.Copy
        Sheets(sht.Name).Range("a1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Next
    Application.ScreenUpdating = True
    ActiveWorkbook.Close True
    Application.DisplayAlerts = True
    Application.CutCopyMode = True
Next
Mailfiles "dave.preswick@xway.com", vFilenames
'For lCount = LBound(vFilenames) To UBound(vFilenames)
'Kill vFilenames(lCount)
'Next
End Sub

Sub Mailfiles(sMailAddress$, vFiles)
Dim oMailItem As Object, oOLapp As Object, lCt&, r As Range
Set oOLapp = CreateObject("Outlook.application")
Set oMailItem = oOLapp.CreateItem(0)
With oMailItem
    .To = sMailAddress
    .Subject = Application.ActiveWorkbook.Name & "  -Summary Sales Report"
    Set r = Workbooks(wn).Sheets("Summary").[a:a].Find(ActiveWorkbook.Name, [a1], xlValues, xlPart)
    If Not r Is Nothing Then .CC = r.Offset(, 1)
    .Body = "Attached please find summary sales per region as at " & Format(Application.EoMonth(Date, -1), _
    "mmm yyyy") & " vs the Prior Year" & vbNewLine & vbNewLine
    .Body = .Body & "Regards" & vbNewLine & vbNewLine
    .Body = .Body & "Simon"
    For lCt = LBound(vFiles) To UBound(vFiles)
        .Attachments.Add CStr(vFiles(lCt))
    Next
    .Display
    Set oOLapp = Nothing
    Set oMailItem = Nothing
End With
End Sub

 

[howard]

Thanks for the hrlp


I get a run time error "item with the specified file was not found" and code below is highlighted


The file selected has a sheet called "Summary"

Set r = Workbooks(wn).Sheets("Summary").[a:a].Find(ActiveWorkbook.Name, [a1], xlValues, xlPart)

Kindly amend Code

 

[Worf]

• I inserted a message box in the version below to help isolate the issue. When testing I got “automation.xlsm” for this workbook (it is the file where the code is) and “c:\pub\2017\delusional.xlsx” for the active one (it is the file opened on the dialog box).
• At the automation workbook, summary sheet, column A, I have the other file name as “delusional.xlsx”, without the path.
• If your setup is different, please explain.

Dim wn$
Sub SendFiles()
Dim lCount As Long, sht As Worksheet, vFilenames, sPath$, lFilecount As Long, sFullName$
sPath = "C:\pub\2017\"      ' your path here
ChDrive sPath
ChDir sPath
wn = ThisWorkbook.Name
vFilenames = Application.GetOpenFilename("Microsoft Excel files (*.xlsx),*.xlsx", , "Select the file(s) to open", , True)
If TypeName(vFilenames) = "Boolean" Then Exit Sub
For lCount = LBound(vFilenames) To UBound(vFilenames)
    Workbooks.Open vFilenames(lCount), UpdateLinks:=False
    Application.CutCopyMode = False
    Sheets(Array("summary")).Copy
    ActiveWorkbook.SaveAs Replace(vFilenames(lCount), ".xlsx", "") & "_summary.xls", FileFormat:=xlNormal
    vFilenames(lCount) = ActiveWorkbook.FullName
    For Each sht In Sheets(Array("summary"))
        Sheets(sht.Name).UsedRange.Copy
        Sheets(sht.Name).[a1].PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Next
    ActiveWorkbook.Close True
    Application.DisplayAlerts = True
    Application.CutCopyMode = True
Next
Mailfiles "dave.preswick@xway.com", vFilenames
'For lCount = LBound(vFilenames) To UBound(vFilenames)
'Kill vFilenames(lCount)
End Sub


Sub Mailfiles(mail_ad$, vFiles)
Dim oMailItem As Object, oOLapp As Object, lCt&, r As Range, sh As Worksheet
'Set oOLapp = CreateObject("Outlook.application")
Set oOLapp = GetObject(, "Outlook.application")
Set oMailItem = oOLapp.CreateItem(0)
With oMailItem
    .To = mail_ad
    .Subject = Application.ActiveWorkbook.Name & "  -Summary Sales Report"
    .Display
    Set sh = Workbooks(wn).Sheets("summary")
    MsgBox "This workbook: " & wn & vbLf & "Active: " & ActiveWorkbook.FullName
    Set r = sh.[a:a].Find(ActiveWorkbook.Name, sh.[a1], xlValues, xlPart)
    If Not r Is Nothing Then .cc = CStr(r.Offset(, 1).Value)
    .Body = "Attached please find summary sales per region as at " & Format(Application.EoMonth(Date, -1), _
    "mmm yyyy") & " vs the Prior Year" & vbNewLine & vbNewLine
    .Body = .Body & "Regards" & vbNewLine & vbNewLine
    .Body = .Body & "Simon"
    For lCt = LBound(vFiles) To UBound(vFiles)
        .Attachments.Add CStr(vFiles(lCt))
    Next
    Set oOLapp = Nothing
    Set oMailItem = Nothing
End With
End Sub

 

[howard]

Thanks for all your help

1) Summary file is not attached
2) email adress in ouutlook under cc not displayed
3) Text in body not displayed



I have attached by file containing Summary as well as the file with the code to email file and attach on Box




https://app.box.com/s/suv9nilgv7tehyfzmgt0ad2mnuevhvwm
https://app.box.com/s/c7e06edzeu70thyj4uqnpcdfx9bten31


My original code produced the following

1) send email address to outlook and tO
2) Attached summary sheet
3) extract text on body of email


The only addition I need is to look up the person to cc in Col B based on the original name of file attached before creating summary sheet to attach





Kindly Test and amend

 

[Worf]

I downloaded your files and the following code worked for me:

Dim wn$
Sub SendFiles()
Dim lCount As Long, sht As Worksheet, vFilenames, sPath$, lFilecount&, sFullName$
sPath = "C:\pub\"      ' your path here
ChDrive sPath
ChDir sPath
wn = ThisWorkbook.Name
vFilenames = Application.GetOpenFilename("Microsoft Excel files (*.xlsx),*.xlsx", , "Select the file(s) to open", , True)
If TypeName(vFilenames) = "Boolean" Then Exit Sub
For lCount = LBound(vFilenames) To UBound(vFilenames)
    Workbooks.Open vFilenames(lCount), UpdateLinks:=False
    Application.CutCopyMode = False
    Sheets(Array("summary")).Copy
    ActiveWorkbook.SaveAs Replace(vFilenames(lCount), ".xlsx", "") & "_summary.xls", FileFormat:=xlNormal
    vFilenames(lCount) = ActiveWorkbook.FullName
    For Each sht In Sheets(Array("summary"))
        Sheets(sht.Name).UsedRange.Copy
        Sheets(sht.Name).[a1].PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Next
    ActiveWorkbook.Close True
    Application.DisplayAlerts = True
    Application.CutCopyMode = True
Next
Mailfiles "dave.preswick@xway.com", vFilenames
'Kill vFilenames(lCount)
End Sub


Sub Mailfiles(mail_ad$, vFiles)
Dim oMailItem As Object, oOLapp As Object, lCt&, r As Range, sh As Worksheet
'Set oOLapp = CreateObject("Outlook.application")
Set oOLapp = GetObject(, "Outlook.application")                                 ' assumes Outlook is open
Set oMailItem = oOLapp.CreateItem(0)
With oMailItem
    .To = mail_ad
    .Subject = Application.ActiveWorkbook.Name & "  -Summary Sales Report"
    .Display
    Set sh = Workbooks(wn).Sheets("sheet1")                                     ' where the CC list is
'    MsgBox "This workbook: " & wn & vbLf & "Active: " & ActiveWorkbook.FullName
    Set r = sh.[a:a].Find(ActiveWorkbook.Name, sh.[a1], xlValues, xlPart)
    If Not r Is Nothing Then .cc = CStr(r.Offset(, 1).Value)
    .Body = "Attached please find summary sales per region as at " & Format(Application.EoMonth(Date, -1), _
    "mmm yyyy") & " vs the Prior Year" & vbNewLine & vbNewLine
    .Body = .Body & "Regards" & vbNewLine & vbNewLine & "Simon"
    For lCt = LBound(vFiles) To UBound(vFiles)
        .Attachments.Add CStr(vFiles(lCt))
    Next
    Set oOLapp = Nothing
    Set oMailItem = Nothing
End With
End Sub

 

[howard]

Thanks for all your help Worf. Your code works perfectly

 

[Worf]

You are welcome and thanks for the feedback.