Zack Barresse
01-22-2012, 06:06 PM
Hello!
I have some code I threw together which is in Excel which takes a workbook, copies data to a new workbook, opens a Word document based on a file in the same location, saves new workbook and document to users desktop, and creates a mail merge between the two. The code executes just fine and without errors, but the document does not seem to be linking to the data source specified. I'm having a hard time with this one and can't spend a whole lot more time with it. :help
I am using Excel and Word 2010.
The process seems simple enough for me, but it's got me stumped.
In the master (original data) file, this is the code I'm using...
Sub MoveDataForMailMerge(Optional Placebo As Variant)
'Check if activesheet is the master data or table of contents name
If ActiveSheet.Name = MasterData.Name Or ActiveSheet.Name = TOC.Name Then
MsgBox "You must select a quarter sheet first (not the Master Data sheet).", vbExclamation, "ERROR!"
Exit Sub
End If
'Make sure this is the action the user wants to take
sPrompt = "Do you want to copy this data to a new workbook for use with Mail Merge?"
msgAsk = MsgBox(sPrompt, vbYesNo + vbDefaultButton2, "APPEND DATA?")
If msgAsk <> vbYes Then Exit Sub
'Set variables
iLastRow = 2
Set WS = ActiveSheet
'Turn off application events
Call TOGGLEEVENTS(False)
'Create a new (blank) workbook for data transfer
Set wbNew = Workbooks.Add(xlWBATWorksheet)
Set wsNew = wbNew.Worksheets(1)
'Add header rows to new workbook
wsNew.Range("A1:I1").Value = Array("Year", "Quarter", "FirstName", "LastName", "Hour", "Minute", "TotalHours", "CBT", "Met Quota")
'Go through first table, add data to new destination workbook as desired
For Each rCell In WS.Range("A5:A" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row).Cells
'Just in case there's a blank row in the table...
If rCell.Value = "" Then GoTo SkipTable1
'Add data
wsNew.Cells(iLastRow, 1).Value = Split(WS.Name, " ")(1)
wsNew.Cells(iLastRow, 2).Value = Split(WS.Name, " ")(0)
wsNew.Cells(iLastRow, 3).Resize(1, 6).Value = rCell.Resize(1, 6).Value
wsNew.Cells(iLastRow, 9).Value = "Yes"
wsNew.Cells(iLastRow, 7).Value = WorksheetFunction.RoundUp(wsNew.Cells(iLastRow, 7).Value, 2)
iLastRow = iLastRow + 1
SkipTable1:
Next rCell
'Go through second table, add data to new destination workbook as desired
For Each rCell In WS.Range("H5:H" & WS.Cells(WS.Rows.Count, "H").End(xlUp).Row).Cells
'Just in case there's a blank row in the table...
If rCell.Value = "" Then GoTo SkipTable2
'Add data
wsNew.Cells(iLastRow, 1).Value = Split(WS.Name, " ")(1)
wsNew.Cells(iLastRow, 2).Value = Split(WS.Name, " ")(0)
wsNew.Cells(iLastRow, 3).Resize(1, 6).Value = rCell.Resize(1, 6).Value
wsNew.Cells(iLastRow, 9).Value = "No"
wsNew.Cells(iLastRow, 7).Value = WorksheetFunction.RoundUp(wsNew.Cells(iLastRow, 7).Value, 2) '/ 24
iLastRow = iLastRow + 1
SkipTable2:
Next rCell
'Get current users desktop path, set file name to be used
sTemp = "C:\Documents and Settings\" & Environ("USERNAME") & "\Desktop\" & Replace(WS.Name, " ", "") & "forMailMerge.xlsx"
'Check if the file exists there already
If Dir(sTemp, vbNormal) <> "" Then
'If file exists there already, ensure user wants to continue (delete, create and save)
sPrompt = "It appears a file already exists. Delete existing and save over?" & DNL & "Word should not be open."
msgAsk = MsgBox(sPrompt, vbYesNo + vbDefaultButton2, "DONE")
If msgAsk <> vbYes Then
'New file doesn't need to do anything, get rid of it and go to exit
wbNew.Close False
GoTo ExitTheSub
End If
'Continuing (user wants to continue), delete file
Kill sTemp
End If
'Save new workbook in xlsx format, then close it
wbNew.SaveAs sTemp, 51
wbNew.Close
'Open a Word application
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
If WordApp Is Nothing Then
Set WordApp = CreateObject("Word.Application")
End If
'Set name and path (template file should reside in the SAME FOLDER as master data file)
sName = "Quarterly Training Hours.docx"
sPath = ThisWorkbook.Path
'Ensure ending character is a path separator, if not, add it
If Right(sPath, 1) <> Application.PathSeparator Then sPath = sPath & Application.PathSeparator
'Open a new document based on template
Set WordDoc = WordApp.Documents.Add(sPath & sName)
'Create letter mail merge
WordDoc.MailMerge.MainDocumentType = 0 'wdFormLetters
'Set temporary name for data source
sTemp = sPath & Left(sName, Len(sName) - 4) & "xlsx"
'Link to data source
WordDoc.MailMerge.OpenDataSource Name:=sTemp, LinkToSource:=True, SQLStatement:="SELECT * FROM Sheet1$"
'Set mail merge specifics
WordDoc.MailMerge.Destination = 0 'wdSendToNewDocument
WordDoc.MailMerge.SuppressBlankLines = True
WordDoc.MailMerge.DataSource.FirstRecord = 1 ' wdDefaultFirstRecord
WordDoc.MailMerge.DataSource.LastRecord = -16 'wdDefaultLastRecord
'Execute mail merge
WordDoc.MailMerge.Execute Pause:=False
'Set new temp variable to users desktop, this time for the Word doc
sTemp = "C:\Documents and Settings\" & Environ("USERNAME") & "\Desktop\" & Replace(WS.Name, " ", "") & "forMailMerge.docx"
'Check if file exists, if it does, delete it
If Dir(sTemp, vbNormal) <> "" Then
Kill sTemp
End If
'Save Word document
WordDoc.SaveAs2 (sTemp)
'Ensure original Excel workbook is the active file
WB.Parent.Activate
'Turn Excel properties back on
Call TOGGLEEVENTS(True)
'Signal user all is well
MsgBox "Process completed successfully!", vbExclamation, "COMPLETE!"
'Show Word
WordApp.Visible = True
'Release Word objects
Set WordDoc = Nothing
Set WordApp = Nothing
'End
Exit Sub
ExitTheSub:
'In case of user quitting, turn events on, tell user they aborted
Call TOGGLEEVENTS(True)
MsgBox "Process aborted.", vbCritical, "ABORTED!"
End Sub
This references code in another module...
Public Sub TOGGLEEVENTS(blnState As Boolean)
'Originally written by Zack Barresse
With Application
If Not blnState And Not ActiveWorkbook Is Nothing Then .Calculation = xlCalculationManual
.DisplayAlerts = blnState
.EnableEvents = blnState
.ScreenUpdating = blnState
If blnState Then .CutCopyMode = False
If blnState Then .StatusBar = False
If blnState And Not ActiveWorkbook Is Nothing Then .Calculation = xlCalculationAutomatic
End With
End Sub
And for simplicity (there are quite a few other routines in this workbook), I put most of my variables in another module, as they're accessed from other routines as well. Here are the applicable one's...
Option Explicit
Public WordApp As Word.Application
Public WordDoc As Word.Document
Public WordMM As Word.MailMerge
Public WB As Workbook
Public WS As Worksheet
Public wbNew As Workbook
Public wsNew As Worksheet
Public iLastRow As Long
Public sPrompt As String
Public sTemp As String
Public sName As String
Public sPath As String
Public msgAsk As VbMsgBoxResult
If you notice in the code I am using Late Binding, but my variables are Early. I changed it to early in trying to debug my code to find out what the problem was. I am probably going to go back to Late Binding, although I don't have to, and can do either/or.
I have some code I threw together which is in Excel which takes a workbook, copies data to a new workbook, opens a Word document based on a file in the same location, saves new workbook and document to users desktop, and creates a mail merge between the two. The code executes just fine and without errors, but the document does not seem to be linking to the data source specified. I'm having a hard time with this one and can't spend a whole lot more time with it. :help
I am using Excel and Word 2010.
The process seems simple enough for me, but it's got me stumped.
In the master (original data) file, this is the code I'm using...
Sub MoveDataForMailMerge(Optional Placebo As Variant)
'Check if activesheet is the master data or table of contents name
If ActiveSheet.Name = MasterData.Name Or ActiveSheet.Name = TOC.Name Then
MsgBox "You must select a quarter sheet first (not the Master Data sheet).", vbExclamation, "ERROR!"
Exit Sub
End If
'Make sure this is the action the user wants to take
sPrompt = "Do you want to copy this data to a new workbook for use with Mail Merge?"
msgAsk = MsgBox(sPrompt, vbYesNo + vbDefaultButton2, "APPEND DATA?")
If msgAsk <> vbYes Then Exit Sub
'Set variables
iLastRow = 2
Set WS = ActiveSheet
'Turn off application events
Call TOGGLEEVENTS(False)
'Create a new (blank) workbook for data transfer
Set wbNew = Workbooks.Add(xlWBATWorksheet)
Set wsNew = wbNew.Worksheets(1)
'Add header rows to new workbook
wsNew.Range("A1:I1").Value = Array("Year", "Quarter", "FirstName", "LastName", "Hour", "Minute", "TotalHours", "CBT", "Met Quota")
'Go through first table, add data to new destination workbook as desired
For Each rCell In WS.Range("A5:A" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row).Cells
'Just in case there's a blank row in the table...
If rCell.Value = "" Then GoTo SkipTable1
'Add data
wsNew.Cells(iLastRow, 1).Value = Split(WS.Name, " ")(1)
wsNew.Cells(iLastRow, 2).Value = Split(WS.Name, " ")(0)
wsNew.Cells(iLastRow, 3).Resize(1, 6).Value = rCell.Resize(1, 6).Value
wsNew.Cells(iLastRow, 9).Value = "Yes"
wsNew.Cells(iLastRow, 7).Value = WorksheetFunction.RoundUp(wsNew.Cells(iLastRow, 7).Value, 2)
iLastRow = iLastRow + 1
SkipTable1:
Next rCell
'Go through second table, add data to new destination workbook as desired
For Each rCell In WS.Range("H5:H" & WS.Cells(WS.Rows.Count, "H").End(xlUp).Row).Cells
'Just in case there's a blank row in the table...
If rCell.Value = "" Then GoTo SkipTable2
'Add data
wsNew.Cells(iLastRow, 1).Value = Split(WS.Name, " ")(1)
wsNew.Cells(iLastRow, 2).Value = Split(WS.Name, " ")(0)
wsNew.Cells(iLastRow, 3).Resize(1, 6).Value = rCell.Resize(1, 6).Value
wsNew.Cells(iLastRow, 9).Value = "No"
wsNew.Cells(iLastRow, 7).Value = WorksheetFunction.RoundUp(wsNew.Cells(iLastRow, 7).Value, 2) '/ 24
iLastRow = iLastRow + 1
SkipTable2:
Next rCell
'Get current users desktop path, set file name to be used
sTemp = "C:\Documents and Settings\" & Environ("USERNAME") & "\Desktop\" & Replace(WS.Name, " ", "") & "forMailMerge.xlsx"
'Check if the file exists there already
If Dir(sTemp, vbNormal) <> "" Then
'If file exists there already, ensure user wants to continue (delete, create and save)
sPrompt = "It appears a file already exists. Delete existing and save over?" & DNL & "Word should not be open."
msgAsk = MsgBox(sPrompt, vbYesNo + vbDefaultButton2, "DONE")
If msgAsk <> vbYes Then
'New file doesn't need to do anything, get rid of it and go to exit
wbNew.Close False
GoTo ExitTheSub
End If
'Continuing (user wants to continue), delete file
Kill sTemp
End If
'Save new workbook in xlsx format, then close it
wbNew.SaveAs sTemp, 51
wbNew.Close
'Open a Word application
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
If WordApp Is Nothing Then
Set WordApp = CreateObject("Word.Application")
End If
'Set name and path (template file should reside in the SAME FOLDER as master data file)
sName = "Quarterly Training Hours.docx"
sPath = ThisWorkbook.Path
'Ensure ending character is a path separator, if not, add it
If Right(sPath, 1) <> Application.PathSeparator Then sPath = sPath & Application.PathSeparator
'Open a new document based on template
Set WordDoc = WordApp.Documents.Add(sPath & sName)
'Create letter mail merge
WordDoc.MailMerge.MainDocumentType = 0 'wdFormLetters
'Set temporary name for data source
sTemp = sPath & Left(sName, Len(sName) - 4) & "xlsx"
'Link to data source
WordDoc.MailMerge.OpenDataSource Name:=sTemp, LinkToSource:=True, SQLStatement:="SELECT * FROM Sheet1$"
'Set mail merge specifics
WordDoc.MailMerge.Destination = 0 'wdSendToNewDocument
WordDoc.MailMerge.SuppressBlankLines = True
WordDoc.MailMerge.DataSource.FirstRecord = 1 ' wdDefaultFirstRecord
WordDoc.MailMerge.DataSource.LastRecord = -16 'wdDefaultLastRecord
'Execute mail merge
WordDoc.MailMerge.Execute Pause:=False
'Set new temp variable to users desktop, this time for the Word doc
sTemp = "C:\Documents and Settings\" & Environ("USERNAME") & "\Desktop\" & Replace(WS.Name, " ", "") & "forMailMerge.docx"
'Check if file exists, if it does, delete it
If Dir(sTemp, vbNormal) <> "" Then
Kill sTemp
End If
'Save Word document
WordDoc.SaveAs2 (sTemp)
'Ensure original Excel workbook is the active file
WB.Parent.Activate
'Turn Excel properties back on
Call TOGGLEEVENTS(True)
'Signal user all is well
MsgBox "Process completed successfully!", vbExclamation, "COMPLETE!"
'Show Word
WordApp.Visible = True
'Release Word objects
Set WordDoc = Nothing
Set WordApp = Nothing
'End
Exit Sub
ExitTheSub:
'In case of user quitting, turn events on, tell user they aborted
Call TOGGLEEVENTS(True)
MsgBox "Process aborted.", vbCritical, "ABORTED!"
End Sub
This references code in another module...
Public Sub TOGGLEEVENTS(blnState As Boolean)
'Originally written by Zack Barresse
With Application
If Not blnState And Not ActiveWorkbook Is Nothing Then .Calculation = xlCalculationManual
.DisplayAlerts = blnState
.EnableEvents = blnState
.ScreenUpdating = blnState
If blnState Then .CutCopyMode = False
If blnState Then .StatusBar = False
If blnState And Not ActiveWorkbook Is Nothing Then .Calculation = xlCalculationAutomatic
End With
End Sub
And for simplicity (there are quite a few other routines in this workbook), I put most of my variables in another module, as they're accessed from other routines as well. Here are the applicable one's...
Option Explicit
Public WordApp As Word.Application
Public WordDoc As Word.Document
Public WordMM As Word.MailMerge
Public WB As Workbook
Public WS As Worksheet
Public wbNew As Workbook
Public wsNew As Worksheet
Public iLastRow As Long
Public sPrompt As String
Public sTemp As String
Public sName As String
Public sPath As String
Public msgAsk As VbMsgBoxResult
If you notice in the code I am using Late Binding, but my variables are Early. I changed it to early in trying to debug my code to find out what the problem was. I am probably going to go back to Late Binding, although I don't have to, and can do either/or.