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!

Caleeco

Administrators
  • Content count

    254
  • Joined

  • Last visited

  • Days Won

    38

Caleeco last won the day on August 30

Caleeco had the most liked content!

Community Reputation

20 Excellent

About Caleeco

  • Rank
    Veteran Lvl.1

Recent Profile Visitors

The recent visitors block is disabled and is not being shown to other users.

  1. Caleeco

    Obtaining Data from CSV Files

    Hey OldFella, I just had a scan of my email account... I couldn't see any files from you in July. Could you please re-send and I'll start coding tomorrow! (It's 1am here). [email protected] Look forward to hearing from you Caleeco
  2. Caleeco

    Obtaining Data from CSV Files

    Hey OldFella! Thanks for getting back to me. Sounds like an interesting problem to solve! Are you able to share any of your source files? This will enable much easier testing (when importing data, the structure of both source and output data is important to understand properly). If not, don't worry I'll create a dummy setup and let you test. Thanks for the udemy link! I'll give it a read Caleeco
  3. Caleeco

    Use SelectionChange Event to Switch Chart

    Ah, that's not a VITAL bit of code.. it's just generally good practice when using the SelectionChange Event. It basically prevents the code running if you select more than one cell with your mouse. Eg... if you selected both B3 and B4 at the same time, the code will get confused and not trigger either event! 😵 Glad it worked 😊 Caleeco
  4. Caleeco

    Use SelectionChange Event to Switch Chart

    Hello Ziya Good to see you again. That's an awesome idea! Certainly something we can use the SelectionChange Event to implement. Try this code out and see if it does what you need. Obviously you'll need to align your charts up first & past the code in the relevant SHEET object and not a VBA module. Private Sub Worksheet_SelectionChange(ByVal Target As Range) '//--- Source: www.ExcelWTF.com '//--- Purpose: Quick Switch between charts If Target.Count > 1 Or Intersect(Target, Range("B3:B4")) Is Nothing Then Exit Sub If Target.Address = "$B$3" Then ActiveSheet.Shapes("Chart 1").ZOrder msoBringToFront If Target.Address = "$B$4" Then ActiveSheet.Shapes("Chart 2").ZOrder msoBringToFront End Sub Hope That Helps Caleeco 😎
  5. Hey Sapron, Awesome, glad we could finally get it working! No problem, I'm always happy to help where I can. Ok great, I look forward to hearing from you on the near future then Caleeco
  6. Hi Sapron, Good spot! Great to see you got that figured out! 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: IF Template Name (Cell D1) Is not found in row Z of each team member AND Template Name (Cell D1) is the same as row AB of each team memeber 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
  7. 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
  8. This is already in the code... is it not triggering correctly? Thanks for the pointers... LOL at item 6 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
  9. 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: Add time stamp in column AA, and record template used in column Z I can't test the print commands as I dont have a printer Need some code to delete the 'temp' files once they are used Probably need some code to close the WORD/Outlook applications after use Can you test the Outmail.Send line works correctly? Tidy up of variables & code Let me know any feedback you have Many Thanks Caleeco
  10. Hi Sapron, Sorry more follow up questions: 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). 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
  11. Hi Sapron, This is going to be a tough cookie to crack! Before I invest time programming. Can we just clarify the requirements. User selects template to be used in Cell D1 Program creates a unique list of MANAGER email addresses 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 Attach all created PDFs for said manager AND copy in Manager of Manager & HR Manager 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
  12. Caleeco

    SUM Multiple Section

    File is on it's way back to you
  13. Caleeco

    SUM Multiple Section

    Hello, ah that's a shame... it was working on the test sheet I had created Yes, please do. My email is [email protected] I look forward to receiving the file! Thanks Caleeco
  14. 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
  15. 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? 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?
×