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

    258
  • Joined

  • Last visited

  • Days Won

    39

Caleeco last won the day on March 6

Caleeco had the most liked content!

Community Reputation

21 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. Hey How are you doing? Welcome to the forum!
  2. No worries, give me a shout if you need any help with the rest of the suite! Caleeco
  3. Hi GeeperZ Thanks for sending over the file. I seem to have a website bug where the NOT (<>) symbol doesnt appear correctly in code samples. If you look at your TransposeData2 sub-routine, you'll see this line of code: Loop While rFound.Address = FirstAddress Change it to this: Loop While rFound.Address <> FirstAddress Tested on my end, seems to work. Let me know how you get on. Thanks Caleeco
  4. Hey GeeperZ Post #2 should be the last 'working' code we made. Has the sheet structure changed at all? Are you able to email me the sheet you're working on so I can do some code testing? Thanks Caleeco
  5. 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
  6. 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
  7. 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
  8. 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 😎
  9. 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
  10. 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
  11. 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
  12. 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
  13. 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
  14. 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
  15. 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
×
×
  • Create New...