A
AndyC812
Hi,
I've pieced together the following code based on advice I got on this forum
and others and from sites referenced by people here. It finally works (well
almost) on Windows with Office 2003. The only problem is it still saves the
changes in the "template" file, even though I specify not to. I need to
clean it up, optimize it and maximize the chances it will run in Office 2007,
Office 2003 and Office:mac 2004. Right now it dies almost immediately on the
Mac. I have not tested on Office 2007 yet.
Would some kind soul be willing to halp me with this?
This is what it should do in words:
1. Open worksheet with Data for Merge (Data Table2)
2. Ask the user what Word template to use (using standard dialog boxes)
3. Ask the user what directory to store the final output (using standard
dialog box)
4. Export the Data in Data Table2 to a CSV file
5. Open the Word Template file
6. Connect the CSV file to it as a data source
7. Merge to New Document
8. Save the new merge document with an Excel derived name
9. Close the template file without saving changes
10. Delete the CSV file
11. Activate the new Word Document and do a spell check
Here's the code as is:
Sub ExportDataTable2()
'
' ExportDataTable2 Macro
'
'
Sheets("Data Table2").Select
Const Delimiter = "\"
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
WriteFileName = Range("C1").Value ' File Name generated and stored in
Excel
' Ask User What template file to use
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Select Report Template to use:"
.InitialFileName = ""
If .Show = -1 Then
TempPathName = .SelectedItems(1)
Else
Exit Sub
End If
End With
'MsgBox "You have selected this template: " & TempPathName
' Ask User what path to store the data to
'
Dim objShell As Object, objFolder As Object
Set objShell = CreateObject("Shell.Application")
On Error Resume Next
Set objFolder = objShell.BrowseForFolder(&H0&, "Select a Folder to Store
This Data ", &H1&)
If Not objFolder Is Nothing Then
Set oFolderItem = objFolder.Items.Item
FPath = oFolderItem.path + "\"
'MsgBox "You have select to save your data to: " & FPath
End If
' Ignore first row - headers
Range("A2").Select
x = ActiveCell.Row
y = ActiveCell.Column
z = 0
Do While Cells(x, y).Value <> ""
x = x + 1
z = z + 1
Loop
'MsgBox "There are " & z & " rows in the data range. Export to CSV file
" & WriteFileName & "?"
' Write data to CSV file
Set fswrite = CreateObject("Scripting.FileSystemObject")
'Set path names
CSVPathName = FPath + WriteFileName + ".csv"
DocPathName = FPath + WriteFileName + ".doc"
' Open and export data to CSV File
fswrite.CreateTextFile CSVPathName
Set fwrite = fswrite.GetFile(CSVPathName)
Set tswrite = fwrite.OpenAsTextStream(ForWriting, TristateUseDefault)
LastRow = z + 1
LastCol = 2
With Sheets("Data Table2")
For ColCount = 1 To LastCol
OutputLine = ""
For RowCount = 2 To LastRow
If OutputLine = "" Then
OutputLine = Cells(RowCount, ColCount).Value
'MsgBox "OutputLine = " & OutputLine
Else
'If ColCount = 2 Then MsgBox RowCount & ": " & Cells(RowCount,
ColCount).Value
OutputLine = OutputLine & Delimiter & Cells(RowCount,
ColCount).Value
End If
Next RowCount
tswrite.writeline OutputLine
Next ColCount
End With
tswrite.Close
'MsgBox "CSV has been written!"
' Sub ControlWordFromXL() - Open Word
Dim oWord As Word.Application
Dim WordWasNotRunning As Boolean
'Get existing instance of Word if it's open; otherwise create a new one
On Error Resume Next
Set oWord = GetObject(, "Word.Application")
If Err Then
Set oWord = New Word.Application
WordWasNotRunning = True
End If
On Error GoTo Err_Handler
oWord.Visible = True
'
' Open the template, merge and save file
'
OpenTemplateAndMerge CSVPathName, DocPathName, TempPathName
'MsgBox "File was saved to " & DocPathName
'
' Delete CSV File
'
Kill CSVPathName
' MergeSpellCheck
'
'
' Set the language for the document.
oWord.Selection.WholeStory
oWord.Selection.LanguageID = wdEnglishUS
oWord.Selection.NoProofing = False
' Perform Spelling/Grammar check.
If oWord.Options.CheckGrammarWithSpelling = True Then
oWord.ActiveDocument.CheckGrammar
Else
oWord.ActiveDocument.CheckSpelling
End If
If WordWasNotRunning Then
oWord.Quit
End If
'Make sure you release object references.
Set oWord = Nothing
'quit
Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error:
" _
& Err.Number
If WordWasNotRunning Then
oWord.Quit
End If
'End Sub
End Sub
Sub OpenTemplateAndMerge(CSVPathName, DocPathName, TempPathName)
'
' CSVPathName = full path to merge data file
' DocPathName = full path to final merge file
' TempPathName = full path to report template
'
'Dim WordApp As Word.Application
Dim Template As Word.Document
'MsgBox "In OpenTemplateAndMerge Subroutine"
' Open the Report Template
Set Template = Word.Documents.Open(TempPathName)
'Old WAY I opened the template
'Documents.Open Filename:=TempPathName, _
' ConfirmConversions:=False, ReadOnly:=False,
AddToRecentFiles:=False, _
' PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
' WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
'wdOpenFormatAuto, XMLTransform:=""
CommandBars("Control Toolbox").Visible = False
'
ActiveDocument.MailMerge.MainDocumentType = wdFormLetters
' Open merge data source file and merge to new document
ActiveDocument.MailMerge.OpenDataSource Name:=CSVPathName, _
ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
Format:=wdOpenFormatAuto, Connection:="", SQLStatement:="",
SQLStatement1 _
:="", SubType:=wdMergeSubTypeOther
With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource ' Data source will always have only one record
.FirstRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
.LastRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
End With
.Execute Pause:=False
End With
' Save Merged File to DocPathName
ActiveDocument.SaveAs Filename:=DocPathName, FileFormat _
:=wdFormatDocument, LockComments:=False, Password:="",
AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False,
EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
' Close Template File
Template.Close (SaveChanges = False) ' Still saves the file changes
End Sub
I've pieced together the following code based on advice I got on this forum
and others and from sites referenced by people here. It finally works (well
almost) on Windows with Office 2003. The only problem is it still saves the
changes in the "template" file, even though I specify not to. I need to
clean it up, optimize it and maximize the chances it will run in Office 2007,
Office 2003 and Office:mac 2004. Right now it dies almost immediately on the
Mac. I have not tested on Office 2007 yet.
Would some kind soul be willing to halp me with this?
This is what it should do in words:
1. Open worksheet with Data for Merge (Data Table2)
2. Ask the user what Word template to use (using standard dialog boxes)
3. Ask the user what directory to store the final output (using standard
dialog box)
4. Export the Data in Data Table2 to a CSV file
5. Open the Word Template file
6. Connect the CSV file to it as a data source
7. Merge to New Document
8. Save the new merge document with an Excel derived name
9. Close the template file without saving changes
10. Delete the CSV file
11. Activate the new Word Document and do a spell check
Here's the code as is:
Sub ExportDataTable2()
'
' ExportDataTable2 Macro
'
'
Sheets("Data Table2").Select
Const Delimiter = "\"
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
WriteFileName = Range("C1").Value ' File Name generated and stored in
Excel
' Ask User What template file to use
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Select Report Template to use:"
.InitialFileName = ""
If .Show = -1 Then
TempPathName = .SelectedItems(1)
Else
Exit Sub
End If
End With
'MsgBox "You have selected this template: " & TempPathName
' Ask User what path to store the data to
'
Dim objShell As Object, objFolder As Object
Set objShell = CreateObject("Shell.Application")
On Error Resume Next
Set objFolder = objShell.BrowseForFolder(&H0&, "Select a Folder to Store
This Data ", &H1&)
If Not objFolder Is Nothing Then
Set oFolderItem = objFolder.Items.Item
FPath = oFolderItem.path + "\"
'MsgBox "You have select to save your data to: " & FPath
End If
' Ignore first row - headers
Range("A2").Select
x = ActiveCell.Row
y = ActiveCell.Column
z = 0
Do While Cells(x, y).Value <> ""
x = x + 1
z = z + 1
Loop
'MsgBox "There are " & z & " rows in the data range. Export to CSV file
" & WriteFileName & "?"
' Write data to CSV file
Set fswrite = CreateObject("Scripting.FileSystemObject")
'Set path names
CSVPathName = FPath + WriteFileName + ".csv"
DocPathName = FPath + WriteFileName + ".doc"
' Open and export data to CSV File
fswrite.CreateTextFile CSVPathName
Set fwrite = fswrite.GetFile(CSVPathName)
Set tswrite = fwrite.OpenAsTextStream(ForWriting, TristateUseDefault)
LastRow = z + 1
LastCol = 2
With Sheets("Data Table2")
For ColCount = 1 To LastCol
OutputLine = ""
For RowCount = 2 To LastRow
If OutputLine = "" Then
OutputLine = Cells(RowCount, ColCount).Value
'MsgBox "OutputLine = " & OutputLine
Else
'If ColCount = 2 Then MsgBox RowCount & ": " & Cells(RowCount,
ColCount).Value
OutputLine = OutputLine & Delimiter & Cells(RowCount,
ColCount).Value
End If
Next RowCount
tswrite.writeline OutputLine
Next ColCount
End With
tswrite.Close
'MsgBox "CSV has been written!"
' Sub ControlWordFromXL() - Open Word
Dim oWord As Word.Application
Dim WordWasNotRunning As Boolean
'Get existing instance of Word if it's open; otherwise create a new one
On Error Resume Next
Set oWord = GetObject(, "Word.Application")
If Err Then
Set oWord = New Word.Application
WordWasNotRunning = True
End If
On Error GoTo Err_Handler
oWord.Visible = True
'
' Open the template, merge and save file
'
OpenTemplateAndMerge CSVPathName, DocPathName, TempPathName
'MsgBox "File was saved to " & DocPathName
'
' Delete CSV File
'
Kill CSVPathName
' MergeSpellCheck
'
'
' Set the language for the document.
oWord.Selection.WholeStory
oWord.Selection.LanguageID = wdEnglishUS
oWord.Selection.NoProofing = False
' Perform Spelling/Grammar check.
If oWord.Options.CheckGrammarWithSpelling = True Then
oWord.ActiveDocument.CheckGrammar
Else
oWord.ActiveDocument.CheckSpelling
End If
If WordWasNotRunning Then
oWord.Quit
End If
'Make sure you release object references.
Set oWord = Nothing
'quit
Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error:
" _
& Err.Number
If WordWasNotRunning Then
oWord.Quit
End If
'End Sub
End Sub
Sub OpenTemplateAndMerge(CSVPathName, DocPathName, TempPathName)
'
' CSVPathName = full path to merge data file
' DocPathName = full path to final merge file
' TempPathName = full path to report template
'
'Dim WordApp As Word.Application
Dim Template As Word.Document
'MsgBox "In OpenTemplateAndMerge Subroutine"
' Open the Report Template
Set Template = Word.Documents.Open(TempPathName)
'Old WAY I opened the template
'Documents.Open Filename:=TempPathName, _
' ConfirmConversions:=False, ReadOnly:=False,
AddToRecentFiles:=False, _
' PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
' WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
'wdOpenFormatAuto, XMLTransform:=""
CommandBars("Control Toolbox").Visible = False
'
ActiveDocument.MailMerge.MainDocumentType = wdFormLetters
' Open merge data source file and merge to new document
ActiveDocument.MailMerge.OpenDataSource Name:=CSVPathName, _
ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
Format:=wdOpenFormatAuto, Connection:="", SQLStatement:="",
SQLStatement1 _
:="", SubType:=wdMergeSubTypeOther
With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource ' Data source will always have only one record
.FirstRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
.LastRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
End With
.Execute Pause:=False
End With
' Save Merged File to DocPathName
ActiveDocument.SaveAs Filename:=DocPathName, FileFormat _
:=wdFormatDocument, LockComments:=False, Password:="",
AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False,
EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
' Close Template File
Template.Close (SaveChanges = False) ' Still saves the file changes
End Sub