PDA

View Full Version : Replace kill command with save command and be able to format date



Saybier
05-25-2020, 11:02 AM
2673826737

Good morning,

I am new to VBA programming. I have found code and managed to alter it to suit what I need with three problems. I cannot seem to be able to replace the kill command and instead save the document in a specific directory. The second issue is that as soon as I format the File Date column on the Customers Sheet to an actual date the program falters. It opens the word document and fills it out but then asks me if I want to save the document, thereby overriding the original with the links and then closes, not finishing the code. The final problem is that I would like to add a column to be able to separate the phone number and the email. I have tried adding a column and changing the column references and the range but it stops working all together.

Can anyone help me with these three issues?

Thank you!
Michelle

Here is the code:


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 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
FrDays = .Range("L3").Value 'Set From Days
ToDays = .Range("N3").Value 'Set To Days
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 DaysSince >= 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("N" & CustRow).Value = TemplName 'Template Name
.Range("O" & CustRow).Value = Now
If .Range("P3").Value = "Email" Then
Set OutApp = CreateObject("Outlook.Application") 'Create Outlook Application
Set OutMail = OutApp.CreateItem(0) 'Create Email
With OutMail
.To = Sheet1.Range("K" & CustRow).Value
.Subject = Sheet1.Range("F" & CustRow).Value & " Report Received"
.Body = "Thank you for your report, a file has been created for repairs."
.Attachments.Add FileName
.Display 'To send without Displaying change .Display to .Send
End With
Else: 'Print Out
WordDoc.PrintOut
WordDoc.Close
End If
Kill (FileName) 'Deletes the PDF or Word that was just created
End If '3 condition met
Next CustRow
WordApp.Quit
End With
End Sub