Jump to content
News Ticker
  • Welcome to the Community
  • Use the forum to troubleshoot your Excel & VBA Problems
  • We will be launching a new website soon! www.ExcelWTF.com/Learn ! Join us to learn VBA from the ground up!
  • 0
Sapron75

Create multiple pdf doucments and send it to 1 email adress

Question

Hi,

I'm working on a vba project for creating pdf documents automatically with excel and then send it to 1 email recipient. If it is 1 document it's easy, but I want to send multiple pdf documents in the same group to the email address which is available in the excel sheet. I'm sure it is possible but I can't get it right. This is the code so far. With this coding individual emails are sent perfect, but not in group :-(  

 

Sub WordDocumentenmaken()
Dim CusRow, CustCol, LastRow, TemplRow As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName, TemplateBonusgrAfhank As String
Dim CurDt, LastAppDt As Date
Dim WordDoc, WordApp, OutApp, OutMail As Object
Dim WordContent As Word.Range
With Blad16

If Range("B3").Value = Empty Then
MsgBox "Please select a correct template from the drop down list"
.Range("D1").Select
Exit Sub
End If
TemplRow = .Range("B3").Value 'Template rij vaststellen
TemplName = .Range("D1").Value 'Template naam vasstellen
DocLoc = Blad1.Range("B" & TemplRow).Value 'Word document naam

'Open het word document template
On Error Resume Next 'Als Word toevallig al loopt
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
'Nieuw Word sessie starten
Err.Clear
'Wanneer fout dan foutbehandeling
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Maakt Word zichtbaar voor gebruiker
End If

LastRow = .Range("C999").End(xlUp).Row 'Laatste rij in tabel bepalen
For CustRow = 6 To LastRow
TemplateBonusgrAfhank = .Range("AB" & CustRow).Value
                If TemplName <> .Range("Z" & CustRow).Value And TemplName = .Range("AB" & CustRow).Value Then
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open de template
For CustCol = 3 To 20 'Dit zijn alle kolommen met de tag naam
TagName = .Cells(5, CustCol).Value 'Je geeft de rijnummer op waarin de tags staan vermeld
TagValue = .Cells(CustRow, CustCol).Value ' Tag waarde
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Forward:=True, Wrap:=wdFindContinue
End With
Next CustCol

If .Range("G1").Value = "PDF" Then
FileName = ThisWorkbook.Path & "\" & .Range("C" & CustRow).Value & " " & .Range("F" & CustRow).Value & " " & .Range("G" & CustRow).Value & " " & .Range("H" & CustRow).Value & " - " & .Range("U" & CustRow).Value & ".pdf" 'creeert file met persnr,voorletter, tussenvoegsel,achternaam en Bonus subgroup
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else 'Als het in Word moet
FileName = ThisWorkbook.Path & "\" & .Range("C" & CustRow).Value & " " & .Range("F" & CustRow).Value & " " & .Range("G" & CustRow).Value & " " & .Range("H" & CustRow).Value & " - " & .Range("U" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
 .Range("Z" & CustRow).Value = TemplName 'Template Name
 .Range("AA" & CustRow).Value = Now

If .Range("G2").Value = "Email" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.Createitem(0)
With OutMail
.To = Blad16.Range("W" & CustRow).Value
.CC = Blad16.Range("X" & CustRow).Value & ";" & Blad16.Range("Y" & CustRow).Value
.Subject = "Bonus letter(s) of your team"
.Body = "Dear " & Blad16.Range("D" & CustRow).Value & " , attached you will find the bonus letter(s) for your team. Please ensure they receive this letter individually within 1 week after receiving this e-mail."
.Attachments.Add FileName
.Display 'Als je zonder van tevoren wilt zien dan .Display to.Send
End With

Else:
WordDoc.PrintOut
WordDoc.Close
End If
Kill (FileName) 'Gooit de pdf of word document weg wat je hebt aangemaakt
End If
Next CustRow
WordApp.Quit
End With
End Sub

The column "W" contain the managers of different people. If I run this code, individual emails are being created for the individual people. I need 1 email with the pdf's of every employee with the same templatename and same Manager email address. 

 

Can you help me with this one ? If you need the file, please let me know where to send it to. Thanks a lot !!

Share this post


Link to post
Share on other sites

23 answers to this question

Recommended Posts

  • 0
12 hours ago, Sapron75 said:

On Error Resume Next
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
Err.Clear

 

This is already in the code... is it not triggering correctly?

 

12 hours ago, Sapron75 said:

1) Indeed the time stamp, very important! I assume this is the code you will use after the pdf or word is saved :

.Range("Z" & CustRow).Value = TemplName
.Range("AA" & CustRow).Value = Now
 

2) Printer I will test next week

3) I simply would say "Kill (wordFilename)" and "Kill (pdfFilename)" somewhere at the end :-)

4) Only code for closing Word, not Outlook, because I always have to review before I definitely send. So the email must be ready to send, and not immediately, so please set it on ".Display" . And Outlook is always running on my pc, so no need to close that.

5) I tested the outmail.send and works like a charm, but as said, must be set to .display

6) When you tidy up, can you adjust the variables for print/email and pdf/word. I didn't realize those 2 are just the headers for making a choice, so it's either print or email, and either word or pdf, so no doubles. Sorry for missing that earlier. This simplifies the code a bit. Again sorry !!

 

Thanks for the pointers... LOL at item 6 xD I should have guessed that. I think i have addressed all of the above, please see the beast of a code below!

 

Sub CreateBonusMessage()
'// Source: www.ExcelWTF.com
    Dim wsAdd, wsTemp As Worksheet
    Dim arrManager As Variant
    Dim arrManagerUnique As New Collection
    Dim a As Variant
    Dim i As Long, lr As Long, CustCol As Long
    Dim WordDoc, WordApp, OutApp, OutMail As Object
    Dim WordContent As Word.Range
    Dim r As Range, RNG As Range
    Dim DocLoc As String
    Dim wordFilename As String, pdfFilename As String, FileTypeOption As String, OutputOption As String
    
    Set wsAdd = Sheets("Adressen def")
    Set wsTemp = Sheets("Templates")
    DocLoc = wsTemp.Range("B" & wsAdd.Range("B3").Value).Value 'Word document naam
    
'//------ Ensure a Template is selected
    If wsAdd.Range("B3").Value = Empty Then
        MsgBox "Please select a correct template from the drop down list"
        wsAdd.Range("D1").Select
        Exit Sub
    End If
    
'//------ Create a Unique list of Manager Names
    lr = wsAdd.Range("D" & Rows.Count).End(xlUp).Row
    arrManager = wsAdd.Range("W6:W" & lr)
    On Error Resume Next
    For Each a In arrManager
        arrManagerUnique.Add a, a
    Next a
     
'//------ Identify the Team Members that report to each manager
    Set RNG = wsAdd.Range("D6:D" & lr)
    For i = 1 To arrManagerUnique.Count
    
    '//------ Create Outlook object
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.Createitem(0)
        
    '//------ Create Word object
        Set WordApp = GetObject("Word.Application")
        If Err.Number <> 0 Then
            Err.Clear 'Nieuw Word sessie starten
            Set WordApp = CreateObject("Word.Application")
            WordApp.Visible = True 'Maakt Word zichtbaar voor gebruiker
        End If
        
    '//------ Define Email and Output Options
        FileTypeOption = wsAdd.Range("G1").Value
        OutputOption = wsAdd.Range("G2").Value
        
        For Each r In RNG
            If wsAdd.Range("W" & r.Row).Value = arrManagerUnique(i) And wsAdd.Range("AB" & r.Row).Value = wsAdd.Range("D1").Value Then
                
            '//------ Create Word Document
                Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open de template
                For CustCol = 3 To 20
                    TagName = wsAdd.Cells(5, CustCol).Value 'Je geeft de rijnummer op waarin de tags staan vermeld
                    TagValue = wsAdd.Cells(r.Row, CustCol).Value ' Tag waarde
                    With WordDoc.Content.Find
                        .Text = TagName
                        .Replacement.Text = TagValue
                        .Wrap = wdFindContinue
                        .Execute Replace:=wdReplaceAll 'Forward:=True, Wrap:=wdFindContinue
                    End With
                Next CustCol
                    
            '//------ Create Word/PDF Document depending on Dropdown
                wordFilename = ThisWorkbook.Path & "\temp\" & wsAdd.Range("C" & r.Row).Value & " " & wsAdd.Range("F" & r.Row).Value & " " & wsAdd.Range("G" & r.Row).Value & " " & wsAdd.Range("H" & r.Row).Value & " - " & wsAdd.Range("U" & r.Row).Value & ".docx"
                pdfFilename = ThisWorkbook.Path & "\temp\" & wsAdd.Range("C" & r.Row).Value & " " & wsAdd.Range("F" & r.Row).Value & " " & wsAdd.Range("G" & r.Row).Value & " " & wsAdd.Range("H" & r.Row).Value & " - " & wsAdd.Range("U" & r.Row).Value & ".pdf"
                If FileTypeOption = "Word" Then
                    WordDoc.SaveAs wordFilename

                ElseIf FileTypeOption = "PDF" Then
                    WordDoc.ExportAsFixedFormat OutputFileName:=pdfFilename, ExportFormat:=wdExportFormatPDF
                    WordDoc.Close False
                End If
                
            '//------ Record Template used and time it was created
                wsAdd.Range("Z" & r.Row).Value = wsAdd.Range("D1").Value
                wsAdd.Range("AA" & r.Row).Value = Now
                
            '//------ Print Word/PDF Document depending on Dropdown
                If OutputOption = "Print" Then WordDoc.PrintOut

            '//------ Create Email and add Attachments
                If OutputOption = "Email" Then
                    With OutMail
                        .Display
                        .To = wsAdd.Range("W" & r.Row).Value
                        .CC = wsAdd.Range("X" & r.Row).Value & ";" & wsAdd.Range("Y" & r.Row).Value
                        .Subject = "Bonus letter(s) of your team"
                        .Body = "Dear " & wsAdd.Range("D" & r.Row).Value & " , attached you will find the bonus letter(s) for your team. Please ensure they receive this letter individually within 1 week after receiving this e-mail."
                        If FileTypeOption = "Word" Then .Attachments.Add wordFilename
                        If FileTypeOption = "PDF" Then .Attachments.Add pdfFilename
                    End With
                    
                    If FileTypeOption = "Word" Then Kill (wordFilename)
                    If FileTypeOption = "PDF" Then Kill (pdfFilename)
                    
                End If
            End If
        Next r
        'OutMail.send
        WordApp.Quit
    Next i

End Sub

 

Let me know if you experience any problems with it!

Kind regards

 

Caleeco  :D

Share this post


Link to post
Share on other sites
  • 0

Hi Caleeco,

 

I think this is a tough one to crack no ? I also tried it with an advanced filter before and after the email coding, but I just don't know how to manage it... Hopefully you will :-) Thanks again !

Share this post


Link to post
Share on other sites
  • 0

Hi Sapron, 

 

Sorry for the delay. The code took a bit of time to decipher... in future, please INDENT your code, it increases legibility :P 

 

I think I now understand your predicament. We will essentially need to Save the PDF files to a Temporary location, and then create the Outlook Object outside of the main loop, attaching all the created files, then deleting said files. 

 

One query about the email list output. Do you wish to have:

  • 1 email with all attachments, to all emails address? (column W and X).

Let me know, 

Thanks

Caleeco

 

 

Share this post


Link to post
Share on other sites
  • 0

Hi Caleeco,

 

No problem for the delay, I'm glad you are helping me. Sorry for the illegibility , I try to keep that in mind in future.

 

The goal is that letters are being created for individual teammembers, but have to be sent to the manager's email (column "W") of that team, so this manager receives 1 email with all the letters for his team. Column "X" and "Y" have to be in the CC.

 

Someone gave me a tip to do this , but in terms of coding I can't get it fixed . This is what the man said :

 

You can do this with the following Steps with VBA
1. Create a Unique List of managers from the 'Adressen def' using Advanced Filters, and put this list in a separate column. (This Unique List can be from either the Manager Name or Manager Email)
2. Run From the First to the Last Name in this Unique List of Managers and for each Managers Name, use this Name as 'Criteria' in a New Advanced Filter.
3. The results will be all names that have this manager.
4. Then run a Loop for all Names within this list and create a unique PDF Filename based on the template assigned to this employee. For each template use .Add Attachment Filename to the single Email
5. Once the last Name in this list has been completed, Send The Email
6. Move the next Manager Name in the Unique list of managers and repeat steps 4 and 5.

 

Thanks so much !!

 

Sapron

 

Share this post


Link to post
Share on other sites
  • 0

Hi Sapron, 

 

Ok I will have a go at what you have stated above. Just 1 question though, what is cell D1 actually used for? O.o

 

Am i correct in assuming it is overidden by what is stated in column U for each team member? So the first email will be:

 

To: [email protected], [email protected], [email protected]

cc: Manager of 1 to [email protected]

Attachments: MIS-1, SIP-2, MIS-3

 

is this correct?

Share this post


Link to post
Share on other sites
  • 0

This is what i have been working on so far by the way!

 

Sub CreateBonusMessage()  
    Dim wsAdd, wsTemp As Worksheet
    Dim arrManager As Variant
    Dim arrManagerUnique As New Collection
    Dim a As Variant
    Dim i As Long, lr As Long
    Dim WordDoc, WordApp, OutApp, OutMail As Object
    Dim WordContent As Word.Range
    Dim r As Range, RNG As Range
    
    
    Set wsAdd = Sheets("Adressen def")
    Set wsTemp = Sheets("Templates")
    
    '//------ Ensure a Template is selected
    If wsAdd.Range("B3").Value = Empty Then
        MsgBox "Please select a correct template from the drop down list"
        wsAdd.Range("D1").Select
        Exit Sub
    End If
    
    lr = wsAdd.Range("D" & Rows.Count).End(xlUp).Row
    '//------ Create a Unique list of Manager Names
    arrManager = wsAdd.Range("W6:W" & lr)
    On Error Resume Next
    For Each a In arrManager
        arrManagerUnique.Add a, a
    Next
    
    '//------ Identify the Team Members that report to each manager
    Set RNG = wsAdd.Range("D6:D" & lr)
    For i = 1 To arrManagerUnique.Count
       For Each r In RNG
        If wsAdd.Range("W" & r.Row).Value = arrManagerUnique(i) Then
            'create the PDF from email here
            'Send email when i = arrManagerUnique.Count
        End If
       Next r
    Next

End Sub

 

Share this post


Link to post
Share on other sites
  • 0
8 hours ago, Caleeco said:

Hi Sapron, 

 

Ok I will have a go at what you have stated above. Just 1 question though, what is cell D1 actually used for? O.o

 

Am i correct in assuming it is overidden by what is stated in column U for each team member? So the first email will be:

 

To: [email protected], [email protected], [email protected]

cc: Manager of 1 to [email protected]

Attachments: MIS-1, SIP-2, MIS-3

 

is this correct?

Hi Caleeco, no the [email protected] emails are not being used. I should have deleted them, because the manager will get the emails. So for each teammember of the manager one email must be sent to that specific manager with multiple attachment (of only his teammembers). Sorry for the misunderstanding, so please don't look at the individual email addresses, but only the managers and their managers/HR managers (in cc.) So emails to column W addresses and cc to X and Y. Hope it is clear now :-)

8 hours ago, Caleeco said:

Hi Sapron, 

 

Ok I will have a go at what you have stated above. Just 1 question though, what is cell D1 actually used for? O.o

 

Am i correct in assuming it is overidden by what is stated in column U for each team member? So the first email will be:

 

To: [email protected], [email protected], [email protected]

cc: Manager of 1 to [email protected]

Attachments: MIS-1, SIP-2, MIS-3

 

is this correct?

O, D1 is to select the template. We have several templates . To select the correct template, the letters will be made for only those who have that specific template.

Share this post


Link to post
Share on other sites
  • 0
8 hours ago, Caleeco said:

This is what i have been working on so far by the way!

 

Sub CreateBonusMessage()  
    Dim wsAdd, wsTemp As Worksheet
    Dim arrManager As Variant
    Dim arrManagerUnique As New Collection
    Dim a As Variant
    Dim i As Long, lr As Long
    Dim WordDoc, WordApp, OutApp, OutMail As Object
    Dim WordContent As Word.Range
    Dim r As Range, RNG As Range
    
    
    Set wsAdd = Sheets("Adressen def")
    Set wsTemp = Sheets("Templates")
    
    '//------ Ensure a Template is selected
    If wsAdd.Range("B3").Value = Empty Then
        MsgBox "Please select a correct template from the drop down list"
        wsAdd.Range("D1").Select
        Exit Sub
    End If
    
    lr = wsAdd.Range("D" & Rows.Count).End(xlUp).Row
    '//------ Create a Unique list of Manager Names
    arrManager = wsAdd.Range("W6:W" & lr)
    On Error Resume Next
    For Each a In arrManager
        arrManagerUnique.Add a, a
    Next
    
    '//------ Identify the Team Members that report to each manager
    Set RNG = wsAdd.Range("D6:D" & lr)
    For i = 1 To arrManagerUnique.Count
       For Each r In RNG
        If wsAdd.Range("W" & r.Row).Value = arrManagerUnique(i) Then
            'create the PDF from email here
            'Send email when i = arrManagerUnique.Count
        End If
       Next r
    Next

End Sub

 

I think you are on the right track :-) Thanks so far and looking forward to see it running perfectly. If you have questions please let me know !

  • Like 1

Share this post


Link to post
Share on other sites
  • 0

Hi Sapron, 

 

This is going to be a tough cookie to crack! Before I invest time programming. Can we just clarify the requirements. 

 

  1. User selects template to be used in Cell D1
  2. Program creates a unique list of MANAGER email addresses
  3. For each MANAGER, the code will create a PDF for ONLY the staff members who belong to that manager AND have the same template as selected in Cell D1
  4. Attach all created PDFs for said manager AND copy in Manager of Manager & HR Manager

256cjsn.jpg

 

So for the example above. Only 2 emails will be created:

Email 1

To: Manager of 4 to [email protected]

cc: Manager of Manager of 4 to [email protected], HR [email protected]

Attachments: MIS OTHER-1 (Jos), MIS OTHER-2 (John)

 

Email 2

To: Manager of 8 to [email protected]

cc: Manager of Manager of 8 to [email protected], HR [email protected]

Attachments: MIS OTHER-1 (Paul)

 

Could you please confirm the above, and I will solve it this week!

Thanks

 

Caleeco

 

Share this post


Link to post
Share on other sites
  • 0

Hi Caleeco,

 

That's exactly the goal ! And important is the columns "Templated used" and "Document sent" which have to be filled automatically after an email has been created, so I know what and when the email was created and no double email can be sent. But that's already in my code .

 

Thanks a lot !!! Looking forward to it !!!!

 

Sapron

Share this post


Link to post
Share on other sites
  • 0

Hi Sapron, 

 

Sorry more follow up questions:

  1. Who are the names listed in column D? are they the names of staff? Because the code you sent me suggests they are the names of the managers. (.Body = "Dear " & Blad16.Range("D" & CustRow).Value).
  2. What are we doing with cells G1 and G2? Do you always want PDFs emailed? or do you want it dependent on the dropdowns you've setup. so one of the 5 outcomes: print, print/email PDF, print/Email Word, email PDF, email word

Let me know

Thanks

Caleeco

Share this post


Link to post
Share on other sites
  • 0

Hi Caleeco, 

 

The body of the email will be changed later, so for the time being please hold column D as an example name reference. I will expand the columns later with more data and then the body will be set up correctly. So at this point no changes have to be made in that regard.

 

It has to be dependendent on the choises in g1 en g2. Mainly it will be email pdf but it can occur that I have to print them and send them by regular mail. And the Word/pdf choise also is a must.

 

Thanks again Caleeco

 

Sapron

Share this post


Link to post
Share on other sites
  • 0

Hi Sapron, 

 

Looks like we're nearly there! I have got the code to create a mixture of Word/PDFs as required, and can attach multiple files to each email. Could you please do some testing on the current code to also confirm this?

 

Please note my Output location for the PDF/Word files is to a 'temp' folder, so please create the subfolder in the same directory.

Sub CreateBonusMessage()
    Dim wsAdd, wsTemp As Worksheet
    Dim arrManager As Variant
    Dim arrManagerUnique As New Collection
    Dim a As Variant
    Dim i As Long, lr As Long
    Dim WordDoc, WordApp, OutApp, OutMail As Object
    Dim WordContent As Word.Range
    Dim r As Range, RNG As Range
    Dim DocLoc As String
    Dim CustCol As Integer
    Dim wordFilename As String, pdfFilename As String, FileTypeOption As String, OutputOption As String
    
    Set wsAdd = Sheets("Adressen def")
    Set wsTemp = Sheets("Templates")
    DocLoc = wsTemp.Range("B" & wsAdd.Range("B3").Value).Value 'Word document naam
    
'//------ Ensure a Template is selected
    If wsAdd.Range("B3").Value = Empty Then
        MsgBox "Please select a correct template from the drop down list"
        wsAdd.Range("D1").Select
        Exit Sub
    End If
    
    
'//------ Create a Unique list of Manager Names
    lr = wsAdd.Range("D" & Rows.Count).End(xlUp).Row
    arrManager = wsAdd.Range("W6:W" & lr)
    On Error Resume Next
    For Each a In arrManager
        arrManagerUnique.Add a, a
    Next a
    
            
'//------ Identify the Team Members that report to each manager
    Set RNG = wsAdd.Range("D6:D" & lr)
    For i = 1 To arrManagerUnique.Count
    
    '//------ Create Outlook object
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.Createitem(0)
        
    '//------ Create Word object
        Set WordApp = GetObject("Word.Application")
        If Err.Number <> 0 Then
            Err.Clear 'Nieuw Word sessie starten
            Set WordApp = CreateObject("Word.Application")
            WordApp.Visible = True 'Maakt Word zichtbaar voor gebruiker
        End If
        
    '//------ Define Email and Output Options
        FileTypeOption = wsAdd.Range("G1").Value
        OutputOption = wsAdd.Range("G2").Value
        
        For Each r In RNG
            If wsAdd.Range("W" & r.Row).Value = arrManagerUnique(i) And wsAdd.Range("AB" & r.Row).Value = wsAdd.Range("D1").Value Then
                
            '//------ Create Word Document
                Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open de template
                For CustCol = 3 To 20
                    TagName = wsAdd.Cells(5, CustCol).Value 'Je geeft de rijnummer op waarin de tags staan vermeld
                    TagValue = wsAdd.Cells(r.Row, CustCol).Value ' Tag waarde
                    With WordDoc.Content.Find
                        .Text = TagName
                        .Replacement.Text = TagValue
                        .Wrap = wdFindContinue
                        .Execute Replace:=wdReplaceAll 'Forward:=True, Wrap:=wdFindContinue
                    End With
                Next CustCol
                    
                    
            '//------ Create Word/PDF Document depending on Dropdown
                wordFilename = ThisWorkbook.Path & "\temp\" & wsAdd.Range("C" & r.Row).Value & " " & wsAdd.Range("F" & r.Row).Value & " " & wsAdd.Range("G" & r.Row).Value & " " & wsAdd.Range("H" & r.Row).Value & " - " & wsAdd.Range("U" & r.Row).Value & ".docx"
                pdfFilename = ThisWorkbook.Path & "\temp\" & wsAdd.Range("C" & r.Row).Value & " " & wsAdd.Range("F" & r.Row).Value & " " & wsAdd.Range("G" & r.Row).Value & " " & wsAdd.Range("H" & r.Row).Value & " - " & wsAdd.Range("U" & r.Row).Value & ".pdf"
                If FileTypeOption = "Word" Then
                    WordDoc.SaveAs wordFilename
                    If OutputOption = "Print" Or OutputOption = "Email/Print" Then WordDoc.PrintOut
                ElseIf FileTypeOption = "PDF/Word" Then
                    WordDoc.SaveAs wordFilename
                    WordDoc.ExportAsFixedFormat OutputFileName:=pdfFilename, ExportFormat:=wdExportFormatPDF
                    If OutputOption = "Print" Or OutputOption = "Email/Print" Then WordDoc.PrintOut
                    WordDoc.Close False
                Else
                    WordDoc.ExportAsFixedFormat OutputFileName:=pdfFilename, ExportFormat:=wdExportFormatPDF
                    If OutputOption = "Print" Or OutputOption = "Email/Print" Then WordDoc.PrintOut
                    WordDoc.Close False
                End If

            '//------ Create Email and add Attachments
                If OutputOption = "Email" Or "Email/Print" Then
                    With OutMail
                        .Display
                        .To = wsAdd.Range("W" & r.Row).Value
                        .CC = wsAdd.Range("X" & r.Row).Value & ";" & wsAdd.Range("Y" & r.Row).Value
                        .Subject = "Bonus letter(s) of your team"
                        .Body = "Dear " & wsAdd.Range("D" & r.Row).Value & " , attached you will find the bonus letter(s) for your team. Please ensure they receive this letter individually within 1 week after receiving this e-mail."
                
                        If FileTypeOption = "Word" Then .Attachments.Add wordFilename
                        If FileTypeOption = "PDF" Then .Attachments.Add pdfFilename
                        If FileTypeOption = "PDF/Word" Then
                            .Attachments.Add wordFilename
                            .Attachments.Add pdfFilename
                        End If
                    End With
                End If
            End If
        Next r
        'OutMail.send
    Next i

End Sub

 

Things I have left to do:

  1. Add time stamp in column AA, and record template used in column Z
  2. I can't test the print commands as I dont have a printer
  3. Need some code to delete the 'temp' files once they are used
  4. Probably need some code to close the WORD/Outlook applications after use
  5. Can you test the Outmail.Send line works correctly?
  6. Tidy up of variables & code

Let me know any feedback you have

Many Thanks

Caleeco

Share this post


Link to post
Share on other sites
  • 0

Hi Caleeco, you rock man !!! I can't test the printing yet (next week), but the rest is exactly what I need.

 

1) Indeed the time stamp, very important! I assume this is the code you will use after the pdf or word is saved :

.Range("Z" & CustRow).Value = TemplName
.Range("AA" & CustRow).Value = Now
 

2) Printer I will test next week

3) I simply would say "Kill (wordFilename)" and "Kill (pdfFilename)" somewhere at the end :-)

4) Only code for closing Word, not Outlook, because I always have to review before I definitely send. So the email must be ready to send, and not immediately, so please set it on ".Display" . And Outlook is always running on my pc, so no need to close that.

5) I tested the outmail.send and works like a charm, but as said, must be set to .display

6) When you tidy up, can you adjust the variables for print/email and pdf/word. I didn't realize those 2 are just the headers for making a choice, so it's either print or email, and either word or pdf, so no doubles. Sorry for missing that earlier. This simplifies the code a bit. Again sorry !!

 

Can you also put in this code when you are going to open Word ?

 

On Error Resume Next
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
Err.Clear
 

Just to avoid problems when Word already running. Probably not...but just to be sure :-)

 

Thanks again !!!

 

Sapron

  • Like 1

Share this post


Link to post
Share on other sites
  • 0

Hi Caleeco, first thing I get is an error I didn't get this morning...strange...

 

It sais that "Dim WordContent As Word.Range" has not been defined.

 

Do you see straight away where the problem lies ?

Thanks and then I can test it big time :-)

Share this post


Link to post
Share on other sites
  • 0

Hi Sapron, 

 

That is very strange.. i just tested the code again, with Existing Word docs open... and with no Word docs open.. and the emails generate as expected. 

 

Is there an error code that pops-up in the message box? I presume, you're working in the same version of excel... and in the same excel file (not saved as an older version of excel). 

 

We may need to switch to late binding. If you run the code i posted two posts ago.. do you get the same error?

 

Let me know

Thanks

Caleeco

Share this post


Link to post
Share on other sites
  • 0

Hi Caleeco, I found the problem. I needed to check the "Microsoft Word 14.0 Object Library" in "Tools-References". Now it works almost great :-) Almost for the part that I do can run the macro twice although there is a timestamp and "template used" available. So I checked the code and saw that this wasn't in :

 

LastRow = .Range("C999").End(xlUp).Row 'Laatste rij in tabel bepalen
For CustRow = 6 To LastRow
TemplateBonusgrAfhank = .Range("AB" & CustRow).Value
                If TemplName <> .Range("Z" & CustRow).Value And TemplName = .Range("AB" & CustRow).Value Then

 

I think this is the missing piece, but I can't integrate it in your code. Can you do this, then the code will be finished finally :-)

 

Thanks again for all your effort and helping with this one !

Hope to hear from you very soon. Sapron

Share this post


Link to post
Share on other sites
  • 0

Hi Sapron, 

 

Good spot! Great to see you got that figured out! :D

 

I was a bit confused by that code.. 

The variable TemplateBonusgrAfhank doesnt actually get used anywhere, so i ignored it. 

 

TemplName = .Range("D1").Value
If TemplName <> .Range("Z" & CustRow).Value And TemplName = .Range("AB" & CustRow).Value Then

The line above is doing the following:

  1. IF Template Name (Cell D1) Is not found in row Z of each team member
  2. AND Template Name (Cell D1) is the same as row AB of each team memeber
  3. THEN run the code

I didnt see the point of line 1 above. Surely row Z and AB should always match? Either way the line I replaced it with is shown below:

If wsAdd.Range("W" & r.Row).Value = arrManagerUnique(i) And wsAdd.Range("AB" & r.Row).Value = wsAdd.Range("D1").Value Then

Can you explain what the code isn't doing? Preferably with an example, and I'll see what code edits are needed. 

 

If you need my code to match exactly the original requirements, this should work:

If wsAdd.Range("W" & r.Row).Value = arrManagerUnique(i) And wsAdd.Range("AB" & r.Row).Value = wsAdd.Range("D1").Value and wsAdd.Range("Z" & r.Row).Value <> wsAdd.Range("D1").Value Then

 

Look forward to hearing from you

Caleeco :) 

 

Share this post


Link to post
Share on other sites
  • 0

Hi Caleeco, thanks for the addition, it works great now. With this addition it will prevent to send the emails twice. If you have 2 persons, no problem, but a team can also be 20 persons, that is why I want to prevent sending double emails. But it works fine now. Finally it's done ! Thank you so much for you time spent in this case. You really helped me a lot !! I wish I could thank you personally, but that's not possible unfortunately.

 

Thank you !! You rock dude!!

 

Ps. I will come back to you later this month with the conditional formatting case...

 

Sapron75

Share this post


Link to post
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now

×