Excel 2013 Macro Help - Open Template as Doc File instead of Template File

Hi

I have after much struggling and googling wrote a macro to do mail merge from Excel. It works well but I have one problem.
When Excel opens the word files it opens the actual template file, instead of say use that template to create a "Document1" or something.
This means that if one person is using this code to do mail merge, the file would be locked and no one else could use it.

Right now Excel opens the file itself, as if it rightclick and chose open, where it uses and alters the template.

Is there any way to have Excel open the file as if I were just doubleclicking the template file (which automatically creates a new unsaved file using the template) and run the mailmerge from that new file?

Thanks in advance.

Here's the code:

Set wdDoc = CreateObject("word.Application")
wdDoc.Documents.Open "Z:\XXXX\Labels Template - With New.dotx"
wdDoc.Visible = True

Dim OrderName As String
OrderName = ThisWorkbook.Path & "\" & ThisWorkbook.Name

On Error Resume Next
Set wdApp = GetObject(, "word.application")
If wdApp Is Nothing Then
Set wdApp = GetObject("Z:\XXXX\Labels Template - With New.dotx", "word.application")
End If
On Error GoTo 0

' Now you start opening the Word application and the document
With wdApp

Set wdDoc = wdApp.Documents.Open(Filename:="Z:\XXXX\Labels Template - With New.dotx")
wdDoc.Application.Visible = True

wdDoc.MailMerge.OpenDataSource _
Name:=OrderName, _
AddToRecentFiles:=False, _
Revert:=False, _
Format:=wdOpenFormatAuto, _
Connection:="Data Source=" & OrderName & ";Mode=Read", _
SQLStatement:="SELECT * FROM `Labels$`"
wdDoc.MailMerge.ViewMailMergeFieldCodes = wdToggle

With wdDoc.MailMerge
.MainDocumentType = wdFormLabels
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
.Execute Pause:=False
End With

to open a new file based on the template, use

Code:

---

set doc = documents.add(templatepath\name)

---

this a new unsaved document, probably named document1 (or2 or 3 etc) until saved

Thank you. It worked.

Another question. If I want to save the exported document, the one I get from

With wdDoc.MailMerge
.MainDocumentType = wdFormLabels
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
.Execute Pause:=False
End With

(not file created from the template, but the one created from that file)
How do I do that? Neither files have saved locations so I can't just use close save changes and trying to use activedocument doesn't seem to work. Is there a way to define these files?

Is there a way I could open the save as window to the desire directory but not save so I can name the file myself?

try

Code:

---

fname = application.getsavefilename
With wdDoc.MailMerge
.MainDocumentType = wdFormLabels
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
.Execute Pause:=False
if not fname = false then .saveAs fname
End With

---

i did not test this you can parse fname to give the file your own name
else use shellbrowseforfolder to just select a folder

Sry I haven't had a chance to test it.

I tried copying my mailmerge code into another file that needs exactly the same thing

And I get Runtime Error 4198 for this portion of the code

Code:

---

wdDoc.MailMerge.OpenDataSource _
Name:=OrderName, _
AddToRecentFiles:=False, _
Revert:=False, _
Format:=wdOpenFormatAuto, _
Connection:="Data Source=" & OrderName & ";Mode=Read", _
SQLStatement:="SELECT * FROM `Labels$`"

---

I don't understand why. Any Idea?

Entire Code is here:

Code:

---

Sub Label_List()
' Scanning_List
' Keyboard Shortcut:
'
' definitions
Dim Order As Worksheet, Tracking As Worksheet, Labels As Worksheet, WorkOrder As Workbook
Set WorkOrder = Excel.ActiveWorkbook
Set Order = WorkOrder.Sheets("Order")
Set Tracking = WorkOrder.Sheets("Tracking")
Set Labels = WorkOrder.Sheets("Labels")
Dim StainingDate As Date
Dim a As Integer, b As Integer, c As Integer, d As Integer, e As Integer, f As Integer
Dim SlideNumber As String

Labels.Select
a = 10
b = 2
c = 10
f = 11

For W = 1 To 4
If Tracking.Cells(9, f).Value <> 0 Then
    If MsgBox("Make Labels for " & Tracking.Cells(9, f).Value & "?", vbYesNo) = vbYes Then
    For x = 1 To 500
    If Tracking.Cells(a, 1).Value <> 0 Then
        For y = 1 To 20
        If Tracking.Cells(a, 1).Value <> 0 And Tracking.Cells(a, f).Value = 1 Then
            Tracking.Select
            Range(Cells(a, 2), Cells(a, 5)).Select
            Selection.Copy
            Labels.Select
            Cells(b, 3).Select
            ActiveSheet.Paste
            If Order.Cells(6, 8).Value <> "N/A" Then Labels.Cells(b, 2).Value = Order.Cells(6, 8).Value
            StainingDate = Tracking.Cells(c + 22, f).Value
            Labels.Cells(b, 12).NumberFormat = ("mmmm"" ""dd"", ""yyyy") ' Date Format
            Labels.Cells(b, 12).Formula = StainingDate ' Enter Scanning Date
            Labels.Cells(b, 13).Value = "Wax-It Histology Services, Inc."
            If Tracking.Cells(9, f).Value = "H&E" Or Tracking.Cells(9, f).Value = "HE" Then
                Labels.Cells(b, 11).Value = "H&E Stain"
            Else
                If Tracking.Cells(9, f).Value = "TRI" Or Tracking.Cells(9, f).Value = "Tri" Then
                    Labels.Cells(b, 11).Value = "Masson's Trichrome"
                Else
                    If Tracking.Cells(9, f).Value = "B+PSR" Then
                        Labels.Cells(b, 11).Value = "Bouin's Pretreated Picro-Sirius Red"
                    Else
                        If Tracking.Cells(9, f).Value = "PSR" Then
                            Labels.Cells(b, 11).Value = "Picro-Sirius Red"
                        Else
                            If Tracking.Cells(9, f).Value = "E5746" Then
                                Labels.Cells(b, 11).Value = "E5746-B3A"
                            Else
                                If Tracking.Cells(9, f).Value = "PAS" Then
                                    Labels.Cells(b, 11).Value = "PAS Stain"
                                Else
                                    Labels.Cells(b, 11).Value = Tracking.Cells(9, f).Value
                                End If
                            End If
                        End If
                    End If
                End If
            End If
            a = a + 1
            b = b + 1
        End If
        If Tracking.Cells(a, 1).Value <> 0 And Tracking.Cells(a, f).Value > 1 Then
            d = Tracking.Cells(a, f).Value
            e = 1
            For Z = 1 To d
            Tracking.Select
            Range(Cells(a, 2), Cells(a, 5)).Select
            Selection.Copy
            Labels.Select
            Cells(b, 3).Select
            ActiveSheet.Paste
            If Order.Cells(6, 8).Value <> "N/A" Then Labels.Cells(b, 2).Value = Order.Cells(6, 8).Value
            StainingDate = Tracking.Cells(c + 22, f).Value
            Labels.Cells(b, 10).Formula = "Slide " & e
            e = e + 1
            Labels.Cells(b, 12).NumberFormat = ("mmmm"" ""dd"", ""yyyy") ' Date Format
            Labels.Cells(b, 12).Formula = StainingDate ' Enter Scanning Date
            Labels.Cells(b, 13).Value = "Wax-It Histology Services, Inc."
            If Tracking.Cells(9, f).Value = "H&E" Or Tracking.Cells(9, f).Value = "HE" Then
                Labels.Cells(b, 11).Value = "H&E Stain"
            Else
                If Tracking.Cells(9, f).Value = "TRI" Or Tracking.Cells(9, f).Value = "Tri" Then
                    Labels.Cells(b, 11).Value = "Masson's Trichrome"
                Else
                    If Tracking.Cells(9, f).Value = "B+PSR" Then
                        Labels.Cells(b, 11).Value = "Bouin's Pretreated Picro-Sirius Red"
                    Else
                        If Tracking.Cells(9, f).Value = "PSR" Then
                            Labels.Cells(b, 11).Value = "Picro-Sirius Red"
                        Else
                            If Tracking.Cells(9, f).Value = "E5746" Then
                                Labels.Cells(b, 11).Value = "E5746-B3A"
                            Else
                                If Tracking.Cells(9, f).Value = "PAS" Then
                                    Labels.Cells(b, 11).Value = "PAS Stain"
                                Else
                                    Labels.Cells(b, 11).Value = Tracking.Cells(9, f).Value
                                End If
                            End If
                        End If
                    End If
                End If
            End If
            b = b + 1
            Next Z
            a = a + 1
        End If
        If Tracking.Cells(a, 1).Value <> 0 And Tracking.Cells(a, f).Value = 0 Then a = a + 1
        Next y
        a = a + 3
        c = c + 23
    If IsEmpty(Range(Cells(a, 1), Cells(a, 5))) Then Exit For
    End If
    Next x
    End If
End If
a = 10
c = 10
f = f + 2
Next W

Set wdDoc = CreateObject("word.Application")

Dim OrderName As String
OrderName = ThisWorkbook.Path & "\" & ThisWorkbook.Name

On Error Resume Next
  '  Error handling
Set wdApp = GetObject(, "word.application")
If wdApp Is Nothing Then
    Set wdApp = GetObject("Z:\5. Employee Folders\Paul\Clerk Work\Making Labels\Labels Template - With New.dotx", "word.application")
End If
On Error GoTo 0
 
With wdApp

Set wdDoc = wdApp.Documents.Add("Z:\5. Employee Folders\Paul\Clerk Work\Making Labels\Labels Template - With New.dotx")
wdDoc.Application.Visible = True

wdDoc.MailMerge.OpenDataSource _
        Name:=OrderName, _
        AddToRecentFiles:=False, _
        Revert:=False, _
        Format:=wdOpenFormatAuto, _
        Connection:="Data Source=" & OrderName & ";Mode=Read", _
        SQLStatement:="SELECT * FROM `Labels$`"
wdDoc.MailMerge.ViewMailMergeFieldCodes = wdToggle

With wdDoc.MailMerge
        .MainDocumentType = wdFormLabels
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        .Execute Pause:=False
End With
   
wdDoc.Application.Visible = True

   
End With

Order.Select
Cells(1, 1).Select
Labels.Select
Cells(1, 1).Select
Tracking.Select
Cells(1, 1).Select

End Sub

---

as you are using on error resume next, it is possible if some errors occur, that wdoc may be a word application object, rather than a document object
though without testing the code it is hard to be sure of what may have happened, probably need to step through the code to see what occurs, comment out OERN see what if any errors happen

EDIT: Found the problem. Forgot to check Microsoft Office Word 15.0 Object Library in References.

Now I get the error message of "Excel is waiting for another application to complete an OLE action." from Excel (not Vba). Once again for the much longer and larger file when using this code.

EDIT2: The previous save code gives me the VBA error "Object doesn't support this property or method" for FName = Application.getsavefilename