Create (word) User form for signature and date using excel VBA

[AawwYeahh]

Ok I am stymied. Please help!
I have gotten code to:
Open word
Open template
Copy cells (from excel)
Paste cells into word

HOWEVER
I want to create name for word document (cell A92 in excel)
Save word document as filename (cell A92 in excel)
As .doc
In folder C:\MidSouth\PENDING

Lock all cells against editing
EXCEPT one cell for signature (in excel cell is A85)
AND one cell for date (in excel cell is G85)

Then close document.



Here is my current code:

Sub CreateWordReport()
Dim WordApp As Word.Application
Set WordApp = New Word.Application

With WordApp
.Visible = True
.Activate
.Documents.Open ("C:\Mem1\Custom Office Templates\Installation Agreement.docm")

Sheets("Contract").Unprotect Password:=""
Range("A1:G92").Select
Selection.Copy
.Selection.Paste

Crossposted at https://www.excelguru.ca/forums/show...sing-excel-VBA

 

[AawwYeahh]

MACROPOD....YOU ARE AWESOME!!!!!!!!!!
After a few tweaks was able to get code create locked populated contract!
(One more request...I Know I know I am pushing it at this point)
I currently have code that will let me create folder/filename based on cell value
I have tried (unsucessfully) to integrate this idea into my new contract idea so that I could save contract directly to client folder vs. parent folder
Here is a copy

Sub FileFolder()
Dim strFilename, strDirname, strPathname, strDefpath As String
On Error Resume Next ' If directory exist goto next line
Worksheets("Dashboard").Select
strDirname = Range("A4").Value ' New directory name

strFilename = Range("Q12").Value 'New file name
strDefpath = "C:\MidSouth\PENDING\" 'Default path name
If IsEmpty(strDirname) Then Exit Sub
If IsEmpty(strFilename) Then Exit Sub

MkDir strDefpath & strDirname
strPathname = strDefpath & strDirname & "\" & strFilename 'create total string

ActiveWorkbook.SaveAs filename:=strPathname, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub

and here is a copy of current working contract code

Sub CreateContract()
Dim wdApp As New Word.Application, wdDoc As New Word.Document, xlSht As Excel.Worksheet
Set xlSht = ActiveWorkbook.Sheets("CONTRACT")
With wdApp
  Application.Visible = True
  Set wdDoc = .Documents.Add(Template:="C:\MemphisCAC\Custom Office Templates\Installation Agreement.dotx")
  With wdDoc
    xlSht.Range("A1:G93").Copy
    .Range.Characters.Last.Paste
    With .Tables(.Tables.Count)
      .Cell(92, 3).Range.Editors.Add wdEditorEveryone
      .Cell(92, 5).Range.Editors.Add wdEditorEveryone
    End With
    .Protect Password:="", Type:=wdAllowOnlyReading
    .SaveAs filename:="C:\MidSouth\PENDING\" & xlSht.Range("A93").Text & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
    .Close False
  End With
  .Quit
End With
Set wdDoc = Nothing: Set wdApp = Nothing: Set xlSht = Nothing
End Sub

thoughts on this idea?
Again, Man you are AWESOME (Thanks so much for your patience!)

 

[Macropod]

If you re-wrote FileFolder as a Function, it could return strDirname for use in your .SaveAs line:

Function FileFolder(strDirname) As String
Const strDefpath As String = "C:\MidSouth\PENDING\" 
If Dir(strDirname, vbDirectory) = "" Then MkDir strDirname
FileFolder = strDefpath  & strDirname & "\"
End Function

.SaveAs filename:=FileFolder(Worksheets("Dashboard").Range("A4").Value) & xlSht.Range("A93").Text & ".docx", _
        FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False

 

[AawwYeahh]

Have run into something trying to implement code when I attempt to run the (createcontract) we had previously built or my (workingcontract ) that I am trying to implement said suggestions into. I receive this (not the pink bar). BTW I went looking for this folder...it does not seem to exist

 

[Macropod]

Function revision:

Function FileFolder(strDirname) As String
Const strDefpath As String = "C:\MidSouth\PENDING\"
strDirname = strDefpath & strDirname
If Dir(strDirname, vbDirectory) = "" Then MkDir strDirname
FileFolder = strDirname & "\"
End Function

 

[AawwYeahh]

Function revision:

Function FileFolder(strDirname) As String
Const strDefpath As String = "C:\MidSouth\PENDING\"
strDirname = strDefpath & strDirname
If Dir(strDirname, vbDirectory) = "" Then MkDir strDirname
FileFolder = strDirname & "\"
End Function

THANK YOU FOR YOUR HELP!!!! THIS WORKS LIKE A CHARM!!!!