Hi everyone,
I have a project I'm struggling with, hoping for some advice.
So, I've created an event register that people can fill in, click 'Create', and it'll open and populate a Word document with details from the register, then email various people to tell them it's done. It works great, looks like this -
What I'm now trying to do is create another macro to approve the register entry - someone will reopen the register, fill in a couple more details, then click 'Approve'. I want it to then reopen the previously created Word doc, populate the extra entries, then email folks again. What I've got looks like this -
Where I'm getting hung up is this bit -
For reference, when the Word doc is created, it also creates a folder with the same name as the Word doc and saves it in this folder.
Any tips?
Thanks!
I have a project I'm struggling with, hoping for some advice.
So, I've created an event register that people can fill in, click 'Create', and it'll open and populate a Word document with details from the register, then email various people to tell them it's done. It works great, looks like this -
VBA Code:
Sub Create_Dev_Folder()
'Set Word Objects
Dim wdApp As Object
Dim wdDoc As Object
Dim wdRng As Word.Range 'Need this to replace text outside of main body (e.g. header/footers)
'Set email objects
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
'Set up Outlook
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Define location paths
Dim FromPath As String
Dim FromForm As String
Dim ToPath As String
'Define initials to email addresses
Dim emailValue As String
Dim iniCell As Range
'Get path for template and new DEV
FromPath = [LISTS!E2]
FromForm = [LISTS!F2]
ToPath = [LISTS!G2] & "\" & ActiveCell
'Copies all files and subfolders from FromPath to (ToPath & "/" & ActiveCell).
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.copyFolder FromPath, ToPath, False
'Opens DEV template
Set wdApp = CreateObject("word.application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Open(ToPath & "\" & FromForm)
'Finds text <DEV NUMBER> and replaces with ActiveCell
For Each wdRng In wdDoc.StoryRanges
With wdRng.Find
.Text = "<DEV NUMBER>"
.Replacement.Text = ActiveCell
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next wdRng
'Finds text <REQ BY> and replaces
For Each wdRng In wdDoc.StoryRanges
With wdRng.Find
.Text = "<REQ BY>"
.Replacement.Text = ActiveCell.Offset(0, 1).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next wdRng
'Finds text <DD/MM/YY> and replaces
For Each wdRng In wdDoc.StoryRanges
With wdRng.Find
.Text = "<DD/MM/YY>"
.Replacement.Text = ActiveCell.Offset(0, 2).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next wdRng
'Finds text <WONUM> and replaces
For Each wdRng In wdDoc.StoryRanges
With wdRng.Find
.Text = "<WONUM>"
.Replacement.Text = ActiveCell.Offset(0, 3).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next wdRng
'Finds text <PRODUCT> and replaces
For Each wdRng In wdDoc.StoryRanges
With wdRng.Find
.Text = "<PRODUCT>"
.Replacement.Text = ActiveCell.Offset(0, 4).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next wdRng
'Finds text <NAVNO> and replaces
For Each wdRng In wdDoc.StoryRanges
With wdRng.Find
.Text = "<NAVNO>"
.Replacement.Text = ActiveCell.Offset(0, 5).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next wdRng
'Finds text <SERNUM> and replaces
For Each wdRng In wdDoc.StoryRanges
With wdRng.Find
.Text = "<SERNUM>"
.Replacement.Text = ActiveCell.Offset(0, 6).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next wdRng
'Finds text <SONUM> and replaces
For Each wdRng In wdDoc.StoryRanges
With wdRng.Find
.Text = "<SONUM>"
.Replacement.Text = ActiveCell.Offset(0, 7).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next wdRng
'Finds text <SUMMARY> and replaces
For Each wdRng In wdDoc.StoryRanges
With wdRng.Find
.Text = "<SUMMARY>"
.Replacement.Text = ActiveCell.Offset(0, 8).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next wdRng
'Save new DEV form
wdDoc.SaveAs (ToPath & "\" & ActiveCell)
'Delete left over DEV template
Kill (ToPath & "\" & FromForm)
Set wdApp = Nothing: Set wdDoc = Nothing: Set wdRng = Nothing
'Finds email addresses from initials dropdown selections
If ActiveCell Is Nothing Then
MsgBox ("No cell is active")
ElseIf ActiveCell.Value = vbNullString Then
MsgBox ("Active cell is empty")
Else
Set iniCell = Worksheets(2).Range("A:A").Find(ActiveCell.Offset(0, 1).Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If iniCell Is Nothing Then
MsgBox ("Couldn't find a match")
Else
emailValue = iniCell.Offset(0, 1)
End If
End If
'Create email in Outlook
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Hello," & vbNewLine & vbNewLine & _
"The above Deviation has been requested and is awaiting approval." & vbNewLine & vbNewLine & _
"**********THIS EMAIL HAS BEEN AUTOMATICALLY GENERATED, PLEASE DO NOT RESPOND**********"
'Sets email addresses
On Error Resume Next
With OutMail
.To = ""
.CC = emailValue
.BCC = ""
.Subject = ActiveCell.Value
.Body = strbody
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
'Creation confirmation
MsgBox ActiveCell.Value & vbNewLine & _
"Deviation has been requested"
End SubWhat I'm now trying to do is create another macro to approve the register entry - someone will reopen the register, fill in a couple more details, then click 'Approve'. I want it to then reopen the previously created Word doc, populate the extra entries, then email folks again. What I've got looks like this -
VBA Code:
Sub Dev_Approval()
'Set Word Objects
Dim wdApp As Object
Dim wdDoc As Object
Dim wdRng As Word.Range 'Need this to replace text outside of main body (e.g. header/footers
'Set email objects
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
'Set up Outlook
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Define location paths
Dim FromPath As String
Dim FromForm As String
Dim ToPath As String
'Define initials to email addresses
Dim emailValue As String
Dim emailValue2 As String
Dim iniCell As Range
Dim iniCell2 As Range
'Get path for template and new DEV
FromPath = [LISTS!E4]
FromForm = ActiveCell & "\" & "ActiveCell.docm"
ToPath = [LISTS!E4] & "\" & ActiveCell
'Opens DEV
Set wdApp = CreateObject("word.application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Open(ToPath & "\" & FromForm)
'Finds text <DEC> and replaces
For Each wdRng In wdDoc.StoryRanges
With wdRng.Find
.Text = "<DEC>"
.Replacement.Text = ActiveCell.Offset(0, 9)
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next wdRng
'Finds text <APP BY> and replaces
For Each wdRng In wdDoc.StoryRanges
With wdRng.Find
.Text = "<APP BY>"
.Replacement.Text = ActiveCell.Offset(0, 10).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next wdRng
'Finds text <ADD/AMM/AYY> and replaces
For Each wdRng In wdDoc.StoryRanges
With wdRng.Find
.Text = "<ADD/AMM/AYY>"
.Replacement.Text = ActiveCell.Offset(0, 11).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next wdRng
'Finds email addresses from initials dropdown selections
If ActiveCell.Offset(0, 9) = "Accepted" Then
Set iniCell = Worksheets(2).Range("A:A").Find(ActiveCell.Offset(0, 1).Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If iniCell Is Nothing Then
MsgBox ("Couldn't find a match")
Else
emailValue = iniCell.Offset(0, 1)
End If
Set iniCell2 = Worksheets(2).Range("A:A").Find(ActiveCell.Offset(0, 10).Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If iniCell2 Is Nothing Then
MsgBox ("Couldn't find a match")
Else
emailValue2 = iniCell2.Offset(0, 1)
End If
End If
'Create Mail in Outlook
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Hello," & vbNewLine & vbNewLine & _
"This Deviation has been APPROVED" & vbNewLine & vbNewLine & _
"**********THIS EMAIL HAS BEEN AUTOMATICALLY GENERATED, PLEASE DO NOT RESPOND**********"
On Error Resume Next
With OutMail
.To = emailValue
.CC = emailValue2
.BCC = "andy.murray@ik-worldwide.com;"
.Subject = ActiveCell.Value
.Body = strbody
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox ActiveCell.Value & vbNewLine & _
"APPROVED"
If ActiveCell.Offset(0, 9) = "REJECTED" Then
Set iniCell = Worksheets(2).Range("A:A").Find(ActiveCell.Offset(0, 1).Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If iniCell Is Nothing Then
MsgBox ("Couldn't find a match")
Else
emailValue = iniCell.Offset(0, 1)
End If
Set iniCell2 = Worksheets(2).Range("A:A").Find(ActiveCell.Offset(0, 10).Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If iniCell2 Is Nothing Then
MsgBox ("Couldn't find a match")
Else
emailValue2 = iniCell2.Offset(0, 1)
End If
End If
'Create Mail in Outlook
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Hello," & vbNewLine & vbNewLine & _
"This Deviation has been REJECTED" & vbNewLine & vbNewLine & _
"**********THIS EMAIL HAS BEEN AUTOMATICALLY GENERATED, PLEASE DO NOT RESPOND**********"
On Error Resume Next
With OutMail
.To = emailValue
.CC = emailValue2
.BCC = ""
.Subject = ActiveCell.Value
.Body = strbody
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox ActiveCell.Value & vbNewLine & _
"REJECTED"
End SubWhere I'm getting hung up is this bit -
VBA Code:
'Opens DEV
Set wdApp = CreateObject("word.application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Open(ToPath & "\" & FromForm)For reference, when the Word doc is created, it also creates a folder with the same name as the Word doc and saves it in this folder.
Any tips?
Thanks!
