I set up my Excel workbook to generate Outlook emails with either a Word or pdf attachment from data entered into a table using VBA.
When I enter the criteria to generate the email with attachment, the attachment name puts "John%20Doe" instead of "John Doe".
How can I get rid of the %20 and have the space between first and last name instead?
Sub CreateWordDocuments()
'CREATE A WORD DOCUMENT TO TRANSFER INFORMATION FROM FILTERED DATA INTO A WORD
TEMPLATE
Dim VSCRow, VSCCol, LastRow, TemplRow, MonthNumber, FromMonth, ToMonth, DaysOfMonth,
FromDays, ToDays As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim CurDt, LastAppDt As Date
Dim WordDoc, WordApp, OutApp, OutMail As Object
Dim WordContent As Word.Range
With Sheet5
If .Range("B3").Value = Empty Then
MsgBox "Please select the correct template from the drop down list"
.Range("F4").Select
Exit Sub
End If
TemplRow = .Range("B3").Value ' Set the Template Value
TemplName = .Range("F4").Value ' Set Template Name
MonthNumber = .Range("V4").Value 'Set the Month Number
FromMonth = .Range("W4").Value
ToMonth = .Range("Y4").Value
DaysOfMonth = .Range("AA4").Value
FromDays = .Range("AC4").Value
ToDays = .Range("AF4").Value
DocLoc = Sheet10.Range("F" & TemplRow).Value ' Word Document Filename
'Open Word Template
On Error Resume Next 'If Word is already open
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
' Launch a new instance of Word
Err.Clear
'On Error GoTo Error_Handler
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Make the application visible to the user
End If
LastRow = .Range("E99999").End(xlUp).Row 'Determine the last Row
For VSCRow = 8 To LastRow
MonthNumber = .Range("X" & VSCRow).Value
DaysOfMonth = .Range("AF" & VSCRow).Value
If TemplName <> .Range("Z" & VSCRow).Value And MonthNumber >= FromMonth And
MonthNumber <= ToMonth And DaysOfMonth >= FromDays And DaysOfMonth <= ToDays Then
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) ' Open
Template
For VSCCol = 5 To 42 'Move through the colunms for information
TagName = .Cells(7, VSCCol).Value 'Tag Name
TagValue = .Cells(VSCRow, VSCCol).Value 'Tag Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Forward:True, Wrap:=wdFindContinue
End With
Next VSCCol
If .Range("H4").Value = "PDF" Then
FileName = ThisWorkbook.Path & "\" & .Range("E" & VSCRow).Value & ".pdf" '
Create full filename and path with current workbook
WordDoc.ExportAsFixedFormat OutputFileName:=FileName,
ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else:
FileName = ThisWorkbook.Path & "\" & .Range("E" & VSCRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
.Range("Z" & VSCRow).Value = TemplName 'Template Name to use
.Range("AA" & VSCRow).Value = Now
If .Range("S4").Value = "Email" Then
Set OutApp = CreateObject("Outlook.Application") 'Create Outlook Application
Set OutMail = OutApp.CreateItem(0) 'Create The Email
With OutMail
.To = Sheet5.Range("Y" & VSCRow).Value
.Subject = "Performance Metrics Verification, " & Sheet5.Range("R" & VSCRow).Value & "
- " & Sheet5.Range("S" & VSCRow).Value & ", " & Sheet5.Range("T" & VSCRow).Value
.Body = "Good afternoon, " & Sheet5.Range("E" & VSCRow).Value & ", here are your " &
Sheet5.Range("R" & VSCRow).Value & " - " & Sheet5.Range("S" & VSCRow).Value & ", " &
Sheet5.Range("T" & VSCRow).Value & " performance metrics as captured by the WFW database
systems. Please review and sign. Comments may be included in the email body. Please
return to me by COB " & Sheet5.Range("AG" & VSCRow).Value & ", If this date falls on a
holiday, return on the next business day following the holiday."
.Attachments.Add FileName
.Display 'To send without displaying .Display to .Send
End With
Else
WordDoc.PrintOut
WordDoc.Close
End If
Kill (FileName) 'Deletes the PDF or Word that was just created
End If '3 conditions are met
Next VSCRow
WordApp.Quit
End With
End Sub
Related
I'm trying to automate an emailing process with outlook.
So far my code enables to:
Send different attachments to different recipients
Send the same range of the excel sheet (ex: A1:B3) as an image in the email body to all the recipients
Personalized message
What I would like is to send different ranges to different recipients (like the attachments) for example:
Email 1: Range A1 B3
Email 2: Range A4:B7
Email 3: Range A8:B11
etc...
Is it possible to make it on loop or sth?
Sub Send_Files()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim MakeJPG As String
Dim PictureRange As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
MakeJPG = CopyRangeToJPG("Sheet1", "F31: J37")
If MakeJPG = "" Then
MsgBox "Something go wrong, we can't create the mail"
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Exit Sub
End If
On Error Resume Next
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
.To = cell.Value
.Subject = Range("B11") & Range("H13") & " - " & cell.Offset(0, 2)
.Attachments.Add MakeJPG, 1, 0
.HTMLBody = "Bonjour " & cell.Offset(0, -1).Value & "," & "<br/>" & "<br/>" & Range("B15") & " " & Range("C15") & " " & Range("D15") & "<p>" & Range("B16") & "<p>" & "<\p>" & "</p><img src=""cid:NamePicture.jpg"" width=550 height=150></html>" & "<p>" & "<\p>" & Range("B17") & .HTMLBody
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
Dim PictureRange As Range
With ActiveWorkbook
On Error Resume Next
.Worksheets(NameWorksheet).Activate
Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
If PictureRange Is Nothing Then
MsgBox "Sorry this is not a correct range"
On Error GoTo 0
Exit Function
End If
PictureRange.CopyPicture
With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
End With
.Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
End With
CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
Set PictureRange = Nothing
End Function
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
Set the initial image range and then offset it after each email sent .
Set rngImage = sh.Range("F27:J28")
Set rngImage = rngImage.Offset(rngImage.Rows.Count)
With the constant TEST = True this code should run without sending emails. If correct set TEST = False.
Option Explicit
Sub Send_Files()
Dim OutApp As Object, OutMail As Object
Dim ws As Worksheet, cell As Range, cellA, rngA As Range
Dim jpgFilename As String, filename As String, html As String
Dim rngImage As Range, sImage As String, n As Long
Const TEST = True ' set to False to use Outlook
Const IMG_NAME = "Image_"
Const IMG_RANGE = "F27:J28" ' first email
If Not TEST Then
Set OutApp = CreateObject("Outlook.Application")
End If
Set ws = Sheets("Sheet1")
Set rngImage = ws.Range(IMG_RANGE) ' first image
' scan column B for valid email addresses
For Each cell In ws.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rngA = cell.Offset(,1).Resize(, 24) ' C:Z attachments
If Application.WorksheetFunction.CountA(rngA) = 0 Then
' no attachments - do nothing
ElseIf cell.Value Like "?*#?*.?*" Then
sImage = IMG_NAME & rngImage.Row & ".jpg" ' unique image name for each email
jpgFilename = CopyRangeToJPG(rngImage, sImage)
' email body
html = "Bonjour " & cell.Offset(0, -1).Value & "," & "<br/><br/>" _
& ws.Range("B15") & " " & ws.Range("C15") & " " & ws.Range("D15") & _
"<p>" & ws.Range("B16") & "</p><br/>" & _
"<img src=""cid:" & sImage & """ width=550 height=150>" & _
"<br/>" & ws.Range("B17")
If TEST Then
MsgBox "Image: " & jpgFilename & vbLf & html, vbInformation, "To: " & cell.Value
'Debug.Print html
Else
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
.To = cell.Value
.Subject = Range("B11") & Range("H13") & " - " & cell.Offset(0, 2)
.Attachments.Add jpgFilename, 1, 0
.HTMLBody = html & .HTMLBody
' add attachments
For Each cellA In rngA.SpecialCells(xlCellTypeConstants)
filename = Trim(cellA.Value)
If filename <> "" Then
If Dir(filename) <> "" Then ' check file exists
.Attachments.Add filename
Else
MsgBox "Could not attach : " & filename, vbExclamation, cell.Value
End If
End If
Next
End With
Set OutMail = Nothing
End If
' next image
Set rngImage = rngImage.Offset(rngImage.Rows.Count)
n = n + 1
End If
Next
Set OutApp = Nothing
MsgBox n & " emails sent", vbInformation
End Sub
Function CopyRangeToJPG(rngImage As Range, filename As String) As String
Dim ws As Worksheet, folder As String
Set ws = rngImage.Parent ' sheet
' check range
If rngImage Is Nothing Then
MsgBox "Sorry this is not a correct range"
CopyRangeToJPG = ""
Exit Function
End If
' create image file
folder = Environ$("temp") & Application.PathSeparator
rngImage.CopyPicture
With ws.ChartObjects.Add(rngImage.Left, rngImage.Top, rngImage.Width, rngImage.Height)
.Activate
.Chart.Paste
.Chart.Export folder & filename, "JPG"
End With
ws.ChartObjects(ws.ChartObjects.Count).Delete
' return status
CopyRangeToJPG = folder & filename
End Function
The VBA code currently works fine, but it will run continuously within the time period assigned to the code. I wish to add some coding, so that the VBA code will stop, once it has sent the first successful mail but still restart the next day. The VBA code is running for 1 hour, and the mail could be sent whenever within this period. Currently the model is sending several mails per day. The VBA is written as per below:
Sub AutoRefresh4(when As Date)
Application.OnTime when, "VLCC_Report"
End Sub
Sub VLCC_Report()
Dim LastSavedDate As Date
LastSavedDate = Format(FileDateTime("XXX"), "dd.mm.yyyy")
Dim TodaysDate As Date
Dim TimeStart, TimeEnd
TimeStart = TimeSerial(10, 0, 0)
TimeEnd = TimeSerial(11, 0, 0)
TodaysDate = Format(Now(), "dd.mm.yyyy")
If TodaysDate = LastSavedDate Then
Application.DisplayAlerts = False
Workbooks.Open ("YYY")
Workbooks.Open ("XXX")
If Workbooks("YYY").Worksheets(2).Range("F1") = 0 Then
Workbooks("XXX").Worksheets(1).Range("A1:Q71").Copy
Workbooks("YYY").Worksheets(2).Range("A2:Q72").PasteSpecial (xlPasteValues)
Workbooks("YYY").Worksheets(2).Range("A1") = "Last Refreshed:"
Workbooks("YYY").Worksheets(2).Range("C1") = Now
End If
End If
If Workbooks("YYY").Worksheets(2).Range("F1") = 1 Then
Dim EmailApplication As Object
Dim EmailItem As Object
Dim Table As Range
Dim Pic As Picture
Dim Sheet As Worksheet
Dim WordDoc As Word.document
Dim Path As String
Dim Filename As String
Dim SHP As Object
Path = "C:\ "
Filename = "VLCC Report" & ".pdf"
Set Sheet = Workbooks("YYY").Worksheets(1)
Set Table = Sheet.Range("B3:I73")
Table.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & Filename, IgnorePrintAreas:=True
Set EmailApplication = CreateObject("Outlook.Application")
Set EmailItem = EmailApplication.CreateItem(0)
Set Sheet = Workbooks("YYY").Worksheets(1)
Set Table = Sheet.Range("B3:I73")
Sheet.Activate
Table.Copy
Set Pic = Sheet.Pictures.Paste
Pic.Cut
With EmailItem
EmailItem.To = "aaa"
EmailItem.CC = ""
EmailItem.Bcc = ""
EmailItem.Importance = 2
EmailItem.Subject = "VLCC Report " & Format(Date, "DD.MM.YYYY")
EmailItem.Attachments.Add ("C:\")
EmailItem.Display
Set WordDoc = EmailItem.GetInspector.WordEditor
With WordDoc.Range
.PasteAndFormat wdChartPicture
.Application.Selection.Paragraphs.Alignment = wdAlignParagraphCenter
With WordDoc.InlineShapes(1)
.ScaleHeight = 110
End With
End With
EmailItem.HTMLBody = "<Body style = font-size:11pt; font-family:Calibri>" & "Hi, <p>Please see table below: <p>" & .HTMLBody
End With
EmailItem.Send
Set EmailItem = Nothing
Set EmailApplication = Nothing
End If
If Workbooks("YYY ").Worksheets(1).Range("F1") = 1 Then
Dim EmailApplication2 As Object
Dim EmailItem2 As Object
Set EmailApplication2 = CreateObject("Outlook.Application")
Set EmailItem2 = EmailApplication.CreateItem(0)
EmailItem.To = "aaa"
EmailItem.CC = ""
EmailItem.Bcc = ""
EmailItem.Importance = 2
EmailItem.Subject = "ERROR: VLCC Report"
EmailItem.Body = "Hi," & Chr(10) & Chr(10) & "Please check VLCC report" & Chr(10) & Chr(10) & "Best regards" & Chr(10) & "André Blokhus"
EmailItem.Send
Set EmailItem = Nothing
Set EmailApplication = Nothing
End If
Application.CutCopyMode = False
Workbooks("XXX").Save
Workbooks("XXX").Close SaveChanges:=False
Workbooks("YYY ").Save
Workbooks("YYY").SaveAs ("YYY, "DD.MM.YY") & ".xlsx?web=1")
Workbooks("YYY - " & Format(Now(), "DD.MM.YY") & ".xlsx").Save
Workbooks("YYY - " & Format(Now(), "DD.MM.YY") & ".xlsx").Close
Application.DisplayAlerts = True
If Time > TimeStart And Time < TimeEnd Then
AutoRefresh4 Now + TimeSerial(0, 15, 0)
Else
If Time < TimeStart Then AutoRefresh4 Date + TimeStart
If Time > TimeStart Then AutoRefresh4 (Date + 1) + TimeStart
End If
End Sub
Short explanation: There are 3.Letter Templates and i want them to print per Button. But the main problem here is, that the Code is Printing the Template for every Person in the Worksheet also if the Person already had a Letter. It should look something like this.
-If the selected letter in "G3" is 1. Letter then send them only to People where the Cell Range in "Z" is Empty
-If the selected letter in "G3" is 2. Letter then send them only to People where the Cell in Range "Z" is 1.Letter
-If the selected letter in "G3" is 3. Letter then send them only to People where the Cell in Range "Z" is 2.Letter
What do i need to write right here?
Thank you for your answer in Advance!
https://i.stack.imgur.com/1NRbv.png
Option Explicit
Sub CreateWordDocuments()
Dim CustRow, CustCol, LastRow, TemplRow, DaysSince, FrDays, ToDays As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim CurDt, LastAppDt As Date
Dim OutApp, OutMail As Object
Dim WordContent As Word.Range
Dim WordDoc As Word.Document
Dim WordApp As Word.Application
With Tabelle1
If IsEmpty(Range("G3").Value) = True Then
MsgBox "Bitte wählen sie eine Vorlage aus"
.Range("G3").Select
Exit Sub
End If
TemplRow = .Range("B3").Value
TemplName = .Range("G3").Value
FrDays = .Range("L3").Value
ToDays = .Range("N3").Value
DocLoc = Tabelle2.Range("F" & TemplRow).Value
On Error Resume Next
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
End If
***LastRow = .Range("E9999").End(xlUp).Row
For CustRow = 8 To LastRow
DaysSince = .Range("P" & CustRow).Value
If TemplName <> .Range("Z" & CustRow).Value And DaysSince >= FrDays And DaysSince <= ToDays Then
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False)
For CustCol = 5 To 26
TagName = .Cells(7, CustCol).Value
TagValue = .Cells(CustRow, CustCol).Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With***
Next CustCol
If .Range("I3").Value = "PDF" Then
FileName = "Filename" & "\" & .Range("H" & CustRow).Value & " " & .Range("G" & CustRow).Value & " " & .Range("G3").Value & ".pdf"
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else:
FileName = ThisWorkbook.Path & "\" & .Range("H" & CustRow).Value & "_" & .Range("G" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
.Range("Z" & CustRow).Value = TemplName
.Range("AA" & CustRow).Value = Now
If .Range("P3").Value = "Email" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Tabelle1.Range("K" & CustRow).Value
.Subject = "Hallo, " & Tabelle1.Range("F" & CustRow).Value & "Test Test Test"
.Body = "Hallo, " & Tabelle1.Range("F" & CustRow).Value & "Test Test Test Test"
.Attachments.Add FileName
.Display
End With
Else:
WordDoc.PrintOut
WordDoc.Close
End If
Kill False '(FileName)
End If
Next CustRow
WordApp.Quit
End With
End Sub
Try the following: (not tested)
Sub CreateWordDocuments()
Dim CustRow As Long, CustCol As Long, LastRow As Long, TemplRow As Long, DaysSince As Long, FrDays As Long, ToDays As Long
Dim DocLoc As String, TagName As String, TagValue As String, TemplName As String, FileName As String
Dim CurDt As Date, LastAppDt As Date
Dim OutApp As Object, OutMail As Object
Dim WordContent As Word.Range
Dim WordDoc As Word.Document
Dim WordApp As Word.Application
'*~
Dim sLastSentTemplate As String
With Tabelle1
If IsEmpty(Range("G3").Value) = True Then
MsgBox "Bitte wählen sie eine Vorlage aus"
.Range("G3").Select
Exit Sub
End If
TemplRow = .Range("B3").Value
TemplName = .Range("G3").Value
FrDays = .Range("L3").Value
ToDays = .Range("N3").Value
DocLoc = Tabelle2.Range("F" & TemplRow).Value
'*~ workout the last sent template name
'* this is what you'll be searching for in column Z
sLastTemplateTarget = GetLastSentTemplate(TemplName)
On Error Resume Next
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
End If
'***LastRow = .Range("E9999").End(xlUp).Row
'*~
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
For CustRow = 8 To LastRow
DaysSince = .Range("P" & CustRow).Value
'*~ changed TemplName to sLastSentTemplate
If sLastSentTemplate = .Range("Z" & CustRow).Value And DaysSince >= FrDays And DaysSince <= ToDays Then
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False)
For CustCol = 5 To 26
TagName = .Cells(7, CustCol).Value
TagValue = .Cells(CustRow, CustCol).Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With '***
Next CustCol
If .Range("I3").Value = "PDF" Then
FileName = "Filename" & "\" & .Range("H" & CustRow).Value & " " & .Range("G" & CustRow).Value & " " & .Range("G3").Value & ".pdf"
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else:
FileName = ThisWorkbook.Path & "\" & .Range("H" & CustRow).Value & "_" & .Range("G" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
.Range("Z" & CustRow).Value = TemplName
.Range("AA" & CustRow).Value = Now
If .Range("P3").Value = "Email" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Tabelle1.Range("K" & CustRow).Value
.Subject = "Hallo, " & Tabelle1.Range("F" & CustRow).Value & "Test Test Test"
.Body = "Hallo, " & Tabelle1.Range("F" & CustRow).Value & "Test Test Test Test"
.Attachments.Add FileName
.Display
End With
Else:
WordDoc.PrintOut
WordDoc.Close
End If
Kill False '(FileName)
End If
Next CustRow
WordApp.Quit
'*~ cleanup after finishing
Set WordApp = Nothing
Set OutApp = Nothing
End With
End Sub
'*~
Function GetLastSentTemplate(sTemplate As String) As String
Dim lPrefixNumber As Long
If Len(sTemplate) > 0 Then
lPrefixNumber = Val(Left(sTemplate, InStr(sTemplate, ".") - 1))
If lPrefixNumber > 1 Then
GetLastSentTemplate = Replace(sTemplate, lPrefixNumber, lPrefixNumber - 1)
End If
End If
End Function
I am using the code below to export a row in an Excel sheet into a Word/pdf file.
It is downloading all non-blank rows.
I want when I select a reference number in a cell dropdown ("CA2"), it only downloads that selected row.
Sub Download_Click()
Dim CustRow, CustCol, LastRow, TemplRow, Reference, RefRow As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim CurDt, LastAppDt As Date
Dim WordDoc, WordApp, OutApp, OutMail As Object
Dim WordContent As Word.Range
With Sheet3
TemplRow = .Range("CI1").Value
TemplName = .Range("BV2").Value
Reference = .Range("CA2").Value
DocLoc = Sheet3.Range("CG2").Value
On Error Resume Next
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
End If
LastRow = .Range("A9999").End(xlUp).Row
For CustRow = 3 To LastRow
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False)
For CustCol = 1 To 70
TagName = .Cells(2, CustCol).Value
TagValue = .Cells(CustRow, CustCol).Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next CustCol
If .Range("BX2").Value = "PDF" Then
FileName = ThisWorkbook.Path & "\" & .Range("B" & CustRow).Value & "_" & .Range("C" & CustRow).Value & ".pdf"
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else
FileName = ThisWorkbook.Path & "\" & .Range("B" & CustRow).Value & "_" & .Range("C" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
Next CustRow
WordApp.Quit
End With
End Sub
As I understand now, your code will export all rows from row 3 to the last row:
For CustRow = 3 To LastRow
If you want only a selected row to be exported, then all you need to do is remove that loop and replace it with a single value, so it only runs once for that value. Remove the above line and replace with this:
CustRow = .Range("CA2").Value
Make sure to remove Next CustRow. Also make sure that cell CA2 contains a numerical value which is a direct reference to the row you need.
I'm struggling for the last 9 hrs trying to create a process that will allow me to auto fill in a Word doc(Template) with information from a excel spreadsheet. I've mapped the word doc to best of my ability using <<>> to match the needed infor from the spreadsheet. But when the Macro is ran it continues the replicate only the some of the data in the first row and the only way to stop the replication is to stop word from the "task manager". Also, I can't figure how to select just the row(s) that I would like to be used to generate the word doc...I'm burnt out at this point.
Please help me.
This is the VBA I'm working with.
Sub CreateWordDocuments()
Dim CustRow, CustCol, LastRow, TemplRow, DaysSince, FrDays, ToDays As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim CurDt, LastAppDt As Date
Dim WordDoc, WordApp, OutApp, OutMail As Object
Dim WordContent As Word.Range
With Sheet1
If .Range("B3").Value = Empty Then
MsgBox "Please select a correct template from the drop down list"
.Range("G3").Select
Exit Sub
End If
TemplRow = .Range("B3").Value 'Set Template Row
TemplName = .Range("G3").Value 'Set Template Name
DocLoc = Sheet2.Range("F" & TemplRow).Value 'Word Document Filename
'Open Word Template
On Error Resume Next 'If Word is already running
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
'Launch a new instance of Word
Err.Clear
'On Error GoTo Error_Handler
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Make the application visible to the user
End If
LastRow = .Range("E9999").End(xlUp).Row 'Determine Last Row in Table
For CustRow = 8 To LastRow
DaysSince = .Range("M" & CustRow).Value
If TemplName <> .Range("N" & CustRow).Value And Row >= FrDays And DaysSince <= ToDays Then
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template
For CustCol = 5 To 13 'Move Through 9 Columns
TagName = .Cells(7, CustCol).Value 'Tag Name
TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Find & Replace all instances
End With
Next CustCol
If .Range("I3").Value = "PDF" Then
FileName = ThisWorkbook.Path & "\" & .Range("E" & CustRow).Value & "_" & .Range("F" & CustRow).Value & ".pdf" 'Create full filename & Path with current workbook location, Last Name & First Name
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else: 'If Word
FileName = ThisWorkbook.Path & "\" & .Range("E" & CustRow).Value & "_" & .Range("F" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
.Range("V" & CustRow).Value = TemplName 'Template Name
.Range("W" & CustRow).Value = Now
WordDoc.Close
End If '3 condition met
Next CustRow
WordApp.Quit
End With
End Sub```