I have got an Excel-Code to generate singular word-mailmerged-documents.
It all work fine. The only problem is that after running the code and closing excel there is still one word instance running in the taskmanager.
Can someone help me fixing this?
My code so far is:
Private Sub CommandButton1_Click()
Dim wordApp As Word.Application
Dim wordTemplate As Word.Document
Dim wordMergedDoc As Word.MailMerge
Dim sourceBookPath As String
Dim sheetSourceName As String
Dim excelColumnFilter As String
Dim queryString As String
Dim baseQueryString As String
Dim wordTemplateDirectory As String
Dim wordTemplateFileName As String
Dim wordTemplateFullPath As String
Dim wordOutputDirectory As String
Dim wordOutputFileName As String
Dim wordOutputFullPath As String
Dim idListValues As Variant
Dim idValue As Integer
Dim idCounter As Integer
Dim recordCounter As Integer
Dim fileCounter As Integer
idListValues = Array(1, 2, 3, 4, 5, 6, 7)
sourceBookPath = ThisWorkbook.FullName
sheetSourceName = "Sheet1"
excelColumnFilter = "Anz"
baseQueryString = "SELECT * FROM `" & sheetSourceName & "$` where `" & excelColumnFilter & "` = [columFilterValue] order by `" & excelColumnFilter & "` ASC"
' Word:
wordTemplateDirectory = ThisWorkbook.Path & "\"
wordTemplateFileName = "sb[columFilterValue].docx"
wordOutputDirectory = ThisWorkbook.Path & "\"
wordOutputFileName = "MailMergeDifferent[columFilterValue]_[Record]"
Set wordApp = New Word.Application
wordApp.Visible = False
wordApp.DisplayAlerts = wdAlertsNone
MsgBox "Verteidigungsanzeigen werden erstellt, bitte kurz warten :)", vbOKOnly + vbInformation, "Information"
For idCounter = 0 To UBound(idListValues)
idValue = idListValues(idCounter)
queryString = Replace(baseQueryString, "[columFilterValue]", idValue)
wordTemplateFullPath = wordTemplateDirectory & Replace(wordTemplateFileName, "[columFilterValue]", idValue)
Set wordTemplate = wordApp.Documents.Open(wordTemplateFullPath)
Set wordMergedDoc = wordTemplate.MailMerge
With wordMergedDoc
.MainDocumentType = wdFormLetters
.OpenDataSource _
Name:=sourceBookPath, _
ReadOnly:=True, _
Format:=wdOpenFormatAuto, _
Revert:=False, _
AddToRecentFiles:=False, _
LinkToSource:=False, _
Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
"Data Source=" & sourceBookPath & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:=queryString
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
For recordCounter = 1 To .DataSource.RecordCount
With .DataSource
.FirstRecord = wordMergedDoc.DataSource.ActiveRecord
.LastRecord = wordMergedDoc.DataSource.ActiveRecord
Dokumentenname = .DataFields("ID")
End With
.Execute Pause:=False
wordOutputFullPath = wordOutputDirectory & Replace(Replace(wordOutputFileName, "[columFilterValue]", idValue), "[Record]", recordCounter)
wordApp.ActiveDocument.SaveAs2 Filename:=wordOutputDirectory & Dokumentenname & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
wordApp.ActiveDocument.Close SaveChanges:=False
.DataSource.ActiveRecord = wdNextRecord
fileCounter = fileCounter + 1
Next recordCounter
End With
wordTemplate.Close False
Next idCounter
wordApp.Visible = False
Set wordApp = Nothing
MsgBox "Geschafft! Es wurden " & fileCounter & " Verteidigungsanzeigen erstellt", vbOKOnly + vbInformation, "Information"
End Sub
Try adding wordApp.Quit right before Set wordApp = Nothing
Related
I'm trying to loop through all word documents in a folder and put all the comments for each file into an Excel workbook.
When I run my code I get the following error "Run-time error '91' Object variable or With block Variable not set.
The code only gets comments from the first file in the directory, then errors, it's not looping.
I've looked at numerous websites and found plenty of references for extracting comments into excel, but not for all word files in a directory.
https://answers.microsoft.com/en-us/msoffice/forum/all/export-word-review-comments-in-excel/54818c46-b7d2-416c-a4e3-3131ab68809c
https://www.mrexcel.com/board/threads/extracting-comments-from-word-document-to-excel.1126759/
This website looked promising for what I need to do, but no one answered his question
Extracting data from multiple word docs to single excel
I updated the code to open each word file, but I get the following error: Run-time error '5': Invalid procedure call or argument
It appears to open each word document but doesn't populate the excel sheet with the comments.
UPDATED CODE:
'VBA List all files in a folder using Dir
Private Sub LoopThroughWordFiles()
'Variable Declaration
Dim sFilePath As String
Dim sFileName As String
Dim i As Integer, HeadingRow As Integer
Dim objPara As Paragraph
Dim objComment As Comment
Dim strSection As String
Dim strTemp
Dim myRange As Range
'Specify File Path
sFilePath = "C:\CommentTest"
'Check for back slash
If Right(sFilePath, 1) <> "\" Then
sFilePath = sFilePath & "\"
End If
'Create an object for Excel.
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
'Create a workbook
Set xlWB = xlApp.Workbooks.Add
'Create Excel worksheet
With xlWB.Worksheets(1)
' Create Heading
HeadingRow = 1
.Cells(HeadingRow, 1).Formula = "File Name"
.Cells(HeadingRow, 2).Formula = "Comment"
.Cells(HeadingRow, 3).Formula = "Page"
.Cells(HeadingRow, 4).Formula = "Paragraph"
.Cells(HeadingRow, 5).Formula = "Comment"
.Cells(HeadingRow, 6).Formula = "Reviewer"
.Cells(HeadingRow, 7).Formula = "Date"
strSection = "preamble" 'all sections before "1." will be labeled as "preamble"
strTemp = "preamble"
xlRow = 1
sFileName = Dir(sFilePath)
MsgBox ("sFileName: " + sFileName)
MsgBox ("sFilePath: " + sFilePath)
vFile = Dir(sFilePath & "*.*")
Do While sFileName <> ""
Set oDoc = Documents.Open(Filename:=sFilePath & vFile)
For i = 1 To ActiveDocument.Comments.count
Set myRange = ActiveDocument.Comments(i).Scope
strSection = ParentLevel(myRange.Paragraphs(1)) ' find the section heading for this comment
'MsgBox strSection
.Cells(i + HeadingRow, 1).Formula = ActiveDocument.Comments(i).Index
.Cells(i + HeadingRow, 2).Formula = ActiveDocument.Comments(i).Reference.Information(wdActiveEndAdjustedPageNumber)
.Cells(i + HeadingRow, 3).Value = strSection
.Cells(i + HeadingRow, 4).Formula = ActiveDocument.Comments(i).Range
.Cells(i + HeadingRow, 5).Formula = ActiveDocument.Comments(i).Initial
.Cells(i + HeadingRow, 6).Formula = Format(ActiveDocument.Comments(i).Date, "MM/dd/yyyy")
.Cells(i + HeadingRow, 7).Formula = ActiveDocument.Comments(i).Range.ListFormat.ListString
Next i
'- CLOSE WORD DOCUMENT
oDoc.Close SaveChanges:=False
vFile = Dir
'Set the fileName to the next available file
sFileName = Dir
Loop
End With
Set xlApp = Nothing
Set xlApp = CreateObject("Excel.Application")
End Sub
Function ParentLevel(Para As Word.Paragraph) As String
'From Tony Jollans
' Finds the first outlined numbered paragraph above the given paragraph object
Dim sStyle As Variant
Dim strTitle As String
Dim ParaAbove As Word.Paragraph
Set ParaAbove = Para
sStyle = Para.Range.ParagraphStyle
sStyle = Left(sStyle, 4)
If sStyle = "Head" Then
GoTo Skip
End If
Do While ParaAbove.OutlineLevel = Para.OutlineLevel
Set ParaAbove = ParaAbove.Previous
Loop
Skip:
strTitle = ParaAbove.Range.Text
strTitle = Left(strTitle, Len(strTitle) - 1)
ParentLevel = ParaAbove.Range.ListFormat.ListString & " " & strTitle
End Function
This version of the Excel macro outputs all the document comments to the active worksheet(starting at row 1), with the filenames in column A.
Sub ImportComments()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, StrCmt As String, StrTmp As String, i As Long, j As Long
StrCmt = Replace("File,Page,Author,Date & Time,H.Lvl,Commented Text,Comment,Reviewer,Resolution,Date Resolved,Edit Doc,Edit By,Edit Date", ",", vbTab)
strFolder = GetFolder: If strFolder = "" Then Exit Sub
Dim wdApp As New Word.Application, wdDoc As Word.Document
wdApp.DisplayAlerts = False: wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With wdDoc
If .Comments.Count > 0 Then
' Process the Comments
For i = 1 To .Comments.Count
StrCmt = StrCmt & vbCr & Split(strFolder, ".doc")(0) & vbTab
With .Comments(i)
StrCmt = StrCmt & .Reference.Information(wdActiveEndAdjustedPageNumber) & _
vbTab & .Author & vbTab & .Date & vbTab
With .Scope.Paragraphs(1).Range
StrCmt = StrCmt & _
.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel").Paragraphs.First.Range.ListFormat.ListString & vbTab
With .Duplicate
.End = .End - 1
StrCmt = StrCmt & Replace(Replace(.Text, vbTab, "<TAB>"), vbCr, "<P>") & vbTab
End With
End With
With .Range.Duplicate
.End = .End - 1
StrCmt = StrCmt & Replace(Replace(.Text, vbTab, "<TAB>"), vbCr, "<P>")
End With
End With
Next
' Update the worksheet
With ActiveSheet
.Columns("E").NumberFormat = "#"
For i = 0 To UBound(Split(StrCmt, vbCr))
StrTmp = Split(StrCmt, vbCr)(i)
For j = 0 To UBound(Split(StrTmp, vbTab))
.Cells(i + 1, j + 1).Value = Split(StrTmp, vbTab)(j)
Next
Next
.Columns("A:M").AutoFit: .Columns("D:E").ColumnWidth = 25
End With
End If
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
wdApp.Quit
' Tell the user we're done.
MsgBox "Finished.", vbOKOnly
' Release object memory
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
Try the following Excel macro. It loops through all Word documents in the selected folder, adding the comments from each commented document to new worksheets in the active workbook.
Sub ImportComments()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, StrCmt As String, StrTmp As String, i As Long, j As Long
strFolder = GetFolder: If strFolder = "" Then Exit Sub
Dim wdApp As New Word.Application, wdDoc As Word.Document, xlWkSht As Worksheet
wdApp.DisplayAlerts = False: wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With wdDoc
If .Comments.Count > 0 Then
StrCmt = Replace("Page,Author,Date & Time,H.Lvl,Commented Text,Comment,Reviewer,Resolution,Date Resolved,Edit Doc,Edit By,Edit Date", ",", vbTab)
' Process the Comments
For i = 1 To .Comments.Count
With .Comments(i)
StrCmt = StrCmt & vbCr & .Reference.Information(wdActiveEndAdjustedPageNumber) & _
vbTab & .Author & vbTab & .Date & vbTab
With .Scope.Paragraphs(1).Range
StrCmt = StrCmt & _
.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel").Paragraphs.First.Range.ListFormat.ListString & vbTab
With .Duplicate
.End = .End - 1
StrCmt = StrCmt & Replace(Replace(.Text, vbTab, "<TAB>"), vbCr, "<P>") & vbTab
End With
End With
With .Range.Duplicate
.End = .End - 1
StrCmt = StrCmt & Replace(Replace(.Text, vbTab, "<TAB>"), vbCr, "<P>")
End With
End With
Next
'Add a new worksheet
Set xlWkSht = .Worksheet.Add
' Update the worksheet
With xlWkSht
.Name = Split(strFile, ".doc")(0)
.Columns("D").NumberFormat = "#"
For i = 0 To UBound(Split(StrCmt, vbCr))
StrTmp = Split(StrCmt, vbCr)(i)
For j = 0 To UBound(Split(StrTmp, vbTab))
.Cells(i + 1, j + 1).Value = Split(StrTmp, vbTab)(j)
Next
Next
.Columns("A:L").AutoFit: .Columns("E:F").ColumnWidth = 25
End With
End If
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
wdApp.Quit
' Tell the user we're done.
MsgBox "Finished.", vbOKOnly
' Release object memory
Set wdDoc = Nothing: Set wdApp = Nothing: Set xlWkSht = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
I tried to MailMerge Word File using VBA codes(in Excel).
When I run the Macro(Code that I wrote), Opening the word file works fine.
However in selecting table in Word for mailmerge, there's no table in selecting option.
Obviously, I typed refData(Excel file) as
refData = "W:\30 Offer\03 MECHANICAL\*Project_Offer_Number_for MECH_210302_ver2.xlsm*"
But in Word file, it is recognized as "W:\30 Offer\03 MECHANICAL.xls" --> and there's no table.
so, I can't click the 'OK button '.
so, I clicked cancel, the the debug pop-up appears with run time error 4198.
Mail Merge part is located at the bottom of codes.
I tried hard to fine the reason, but I'm new in VBA, so it's quiet hard to find and fix it.
So, I need some helps.
If you have time to read my codes, please help me.
Thank you.
Private Function folder_exister(flderName As String) As Boolean 'Existing Folder Tester
If Len(Dir(flderName, vbDirectory)) <> 0 Then
folder_exister = True
Else
folder_exister = False
End If
End Function
Sub Gen_Offer_folder()
'Common Declaration-------------------------------------------------------------------
Dim r As Integer 'Codes for Latest Row
Sheets("Offer").Select
Cells(14, 2).Select
Selection.End(xlDown).Select
r = Selection.Row
Dim CoName As String, EndCusName As String
Dim OffrNm As String, Pjt As String
Dim ResPer As String
CoName = Cells(r, 4).Value
EndCusName = Cells(r, 5).Value
OffrNm = Cells(r, 2).Value
ResPer = Cells(r, 6).Value
Pjt = Cells(r, 3).Value
Dim MainDir As String
Dim ComDir As String
Dim PjtDir As String
Dim TempDir As String
MainDir = "W:\30 Offer\03 MECHANICAL"
ComDir = "W:\30 Offer\03 MECHANICAL\" & CoName
PjtDir = "W:\30 Offer\03 MECHANICAL\" & CoName & "\" & OffrNm & " " & EndCusName & " " & Pjt
TempDir = MainDir & "\_New Rule_Customer location\Offer No_project name"
'Create Folders & Files---------------------------------------------------------
Dim FSO As Object
Dim strFromFolder As String
Dim strToFolder As String
If folder_exister(ComDir) Then 'create sub-folders in existing folder
If folder_exister(PjtDir) Then
Set FSO = CreateObject("scripting.filesystemobject")
strFromFolder = "W:\30 Offer\03 MECHANICAL\_New Rule_Customer location\Offer No_project name"
strToFolder = PjtDir
FSO.CopyFolder _
Source:=strFromFolder, Destination:=strToFolder, overwritefiles:=True
Else
MkDir PjtDir
Set FSO = CreateObject("scripting.filesystemobject")
strFromFolder = "W:\30 Offer\03 MECHANICAL\_New Rule_Customer location\Offer No_project name"
strToFolder = PjtDir
FSO.CopyFolder _
Source:=strFromFolder, Destination:=strToFolder, overwritefiles:=True
End If
Else 'create sub-folders in generated folder
MkDir ComDir
MkDir PjtDir
Set FSO = CreateObject("scripting.filesystemobject")
strFromFolder = "W:\30 Offer\03 MECHANICAL\_New Rule_Customer location\Offer No_project name"
strToFolder = PjtDir
FSO.CopyFolder _
Source:=strFromFolder, Destination:=strToFolder, overwritefiles:=True
End If
Set FSO = Nothing
'Fill the calc sheet-------------------------------------------------------------
Dim a As String, b As String, c As String, d As String, e As String, f As String, g As String, h As String
a = ThisWorkbook.Sheets("Offer").Cells(r, 2).Value 'Offer Number
b = ThisWorkbook.Sheets("Offer").Cells(r, 3).Value 'Pjt Name
c = ThisWorkbook.Sheets("Offer").Cells(r, 4).Value 'Customer Name
d = ThisWorkbook.Sheets("Offer").Cells(r, 5).Value 'End Customer Name
e = ThisWorkbook.Sheets("Offer").Cells(r, 6).Value 'Resp. Person
Dim wkb As Workbook
Application.ScreenUpdating = False
Set wkb = Workbooks.Open(PjtDir & "\01_COSTS\13_COST_BASIS\" & "Offer calc_offerNr_pjt name_date.xlsx")
With wkb
With .Worksheets("Calc sheet")
.Range("A3").Value = Date 'Date
.Range("J14").Value = Date 'Date
.Range("G12").Value = Date 'Date
.Range("B3").Value = e 'Resp. Name
.Range("J13").Value = e 'Resp. Name
.Range("G13").Value = Today 'Updated Day <-- Today
.Range("B10").Value = c
.Range("B11").Value = d
.Range("B12").Value = b
.Range("G10").Value = a
End With
.Close SaveChanges:=True 'save changes then close
End With
Set wkb = Nothing
'change offer calc name------------------------------------------------------------
Dim oldName As String, newName As String
oldName = PjtDir & "\01_COSTS\13_COST_BASIS\Offer calc_offerNr_pjt name_date.xlsx"
newName = PjtDir & "\01_COSTS\13_COST_BASIS\Offer calc_" & OffrNm & "_" & EndCusName & "_" & Pjt & "_" & Date & ".xlsx"
On Error GoTo Here 'If the File is aready exist, then These Codes DO NOT Create New One or Overwite.
Name oldName As newName
Exit Sub
Here:
MsgBox "Already Existing Calc Sheet File"
'Mail Merge(Word File)///////////////////////////////////////////////////////////////
'Create Offer doc sheet at Calc Sheet for MailMerge
With ThisWorkbook
.Sheets("for_MailMerge").Range("a2").Value = Pjt
.Sheets("for_MailMerge").Range("b2").Value = OffrNm
.Sheets("for_MailMerge").Range("c2").Value = CoName
.Sheets("for_MailMerge").Range("d2").Value = EndCusName
.Sheets("for_MailMerge").Range("e2").Value = Date
.Sheets("for_MailMerge").Range("f2").Value = ResPer
End With
'Create Word File Object
Dim Wrd As Object
Set Wrd = CreateObject("word.application")
Wrd.Visible = True
Dim wrdPath As String, refData As String, xlConnectionString As String
wrdPath = "W:\30 Offer\03 MECHANICAL\_New Rule_Customer location\Offer No_project name\02_OFFER\Offer_OfferNr_pjt name_date.doc"
refData = "W:\30 Offer\03 MECHANICAL\Project_Offer_Number_for MECH_210302_ver2.xlsm"
'Open THE Word File
Wrd.Documents.Open Filename:=wrdPath
'Write on Word
Wrd.ActiveDocument.MailMerge.MainDocumentType = wdFormLetters
'Define Connection String
xlConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "User ID=Admin;" _
& "Data Source=" + refData + ";" _
& "Mode=Read;" _
& "Extended Porperties=""" _
& "HDR=YES;" _
& "IMEX=;"";" _
& "Jet OLEDB:System database="""";" _
& "Jet OLEDB:Regist"
'Open a Connection to the Excel 'For word template file
With Wrd.ActiveDocument.MailMerge
.OpenDataSource _
Name:=refData, _
LinkToSource:=True, _
Connection:=xlConnectionString, _
SQLStatement:="SELECT * FROM 'for_MailMerge$`"
'Simulate running the mail merge and return any errors
.Check
'We can see either the Values(False) or the Fields Name(True)
.ViewMailMergeFieldCodes = False
'Specify the destination
.Destination = wdSendToNewDocumunent
'Execute the mail merger, and don't pause for errors
.Execute Pause:=False
End With
'for Created word file
Wrd.ActiveDocument.SaveAs Filename:=PjtDir & "\02_OFFER" & "Offer_" & OffrNm & "_" & Pjt & "_" & Date & ".doc"
Wrd.ActiveWindow.Close
Wrd.ActiveDocument.Close SaveChanges:=True
Wrd.Quit
Set Wrd = Nothing
MsgBox "Completed"
ActiveWorkbook.Save
End Sub
If your Word document has been saved as a mailmerge main document, your code will stall waiting for you to answer the mailmerge SQL prompt. To overcome that you need to employ:
Wrd.DisplayAlerts = wdAlertsNone
before:
Wrd.Documents.Open Filename:=wrdPath
Your SQL statement is also malformed.
For more, see Run a Mailmerge from Excel, Sending the Output to Individual Files in: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
I want my VBA Excel Mail Merge with Word to skip empty records. Currently when an the data record turns up empty from my query I get a Run-Time error '5631' stating that "Word could not merge the main document with the data source because the data records were empty or not data records matched your query options." The program then stalls at ".Execute Pause:=False". My current macro is as follows:
Sub RunMailMerge()
Dim fdObj As Object, wd As Object, wdocSource As Object
Dim strWorkbookName, strPath As String
Dim dteStart As Date, dteEnd As Date
Dim numUnit As Integer
Dim ptsArray As Variant
Dim strPtName As Variant
Dim i As Long, numLastPt As Long
Dim pctdone As Single
dteStart = ThisWorkbook.Sheets("Group Dates").Range("F2")
dteEnd = ThisWorkbook.Sheets("Group Dates").Range("F3")
strPath = ThisWorkbook.Path & "\" & Format(dteStart, "yyyyMM") & "-MonthlyNotes\"
ptsArray = ThisWorkbook.Worksheets("Patients").Range("PtNames").value
numLastPt = ThisWorkbook.Worksheets("Patients").Range("PtNames").Count
i = 1
ufProgress.LabelProgress.Width = 0
'Make new folder if it does not exist
Set fdObj = CreateObject("Scripting.FileSystemObject")
If fdObj.FolderExists(strPath) Then
MsgBox "Found " & Format(dteStart, "yyyyMM") & "-MonthlyNotes. Ready to Print?", vbInformation, "CPT Group Notes"
Else
fdObj.CreateFolder (strPath)
MsgBox Format(dteStart, "yyyyMM") & "-MonthlyNotes has been created. Ready to Print?", vbInformation, "CPT Group Notes"
End If
ufProgress.Show
'iterating through each patient using For each loop.
For Each strPtName In ptsArray
Application.ScreenUpdating = False
On Error Resume Next
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
Set wd = CreateObject("Word.Application")
End If
On Error GoTo 0
If Dir(ThisWorkbook.Path & PatientReportPath) <> "" Then
pctdone = i / numLastPt
With ufProgress
.LabelCaption.Caption = "Processing Row " & i & " of " & numLastPt & " " & vbCrLf & strPtName
.LabelProgress.Width = pctdone * (.FrameProgress.Width)
End With
Set wdocSource = wd.Documents.Open(ThisWorkbook.Path & PatientReportPath)
strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
wdocSource.MailMerge.MainDocumentType = wdFormLetters
wdocSource.MailMerge.OpenDataSource _
Name:=strWorkbookName, _
AddToRecentFiles:=False, _
Revert:=False, _
Format:=wdOpenFormatAuto, _
Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
SQLStatement:="SELECT * FROM `tblMailMerge` WHERE `Patient Name` = '" & strPtName & "' AND `DATE` BETWEEN #" & dteStart & "# AND #" & dteEnd & "# ORDER BY `DATE` DESC;"
On Error GoTo noprint
With wdocSource.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
'The output document will automatically be the 'active' one
wd.Visible = True
With wd.ActiveDocument
wd.Run ("UniteRecords")
.SaveAs Filename:=strPath & strPtName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
'Close the output file
.Close SaveChanges:=False
End With
noprint:
wdocSource.Close SaveChanges:=False
Set wdocSource = Nothing
Set wd = Nothing
If i = numLastPt Then
Unload ufProgress
wd.Visible = False
Shell "explorer.exe" & " " & strPath, vbNormalFocus
End If
i = i + 1
Else
MsgBox "File ' " & ThisWorkbook.Path & PatientReportPath & "' does not exist!"
End If
Application.ScreenUpdating = True
Next
End Sub
Essentially I would like to modify the code with something like this
If wdocSource.MailMerge.RecordCount > 0 Then
With wdocSource.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
'The output document will automatically be the 'active' one
wd.Visible = True
With wd.ActiveDocument
wd.Run ("UniteRecords")
.SaveAs Filename:=strPath & strPtName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
'Close the output file
.Close SaveChanges:=False
End With
noprint:
wdocSource.Close SaveChanges:=False
Set wdocSource = Nothing
Set wd = Nothing
End If
But RecordCount does not work in this case. So any tips will be greatly appreciated.
Thanks slightly snarky and macropod. You pointed me in the right direction of trapping that error. After messing around with it, this trap works::
Sub RunMailMerge()
Dim fdObj As Object, wd As Object, wdocSource As Object
Dim strWorkbookName, strPath As String
Dim dteStart As Date, dteEnd As Date
Dim numUnit As Integer
Dim ptsArray As Variant
Dim strPtName As Variant
Dim i As Long, numLastPt As Long
Dim pctdone As Single
dteStart = ThisWorkbook.Sheets("Group Dates").Range("F2")
dteEnd = ThisWorkbook.Sheets("Group Dates").Range("F3")
strPath = ThisWorkbook.Path & "\" & Format(dteStart, "yyyyMM") & "-MonthlyNotes\"
ptsArray = ThisWorkbook.Worksheets("Patients").Range("PtNames").value
numLastPt = ThisWorkbook.Worksheets("Patients").Range("PtNames").Count
i = 1
ufProgress.LabelProgress.Width = 0
'Make new folder if it does not exist
Set fdObj = CreateObject("Scripting.FileSystemObject")
If fdObj.FolderExists(strPath) Then
MsgBox "Found " & Format(dteStart, "yyyyMM") & "-MonthlyNotes. Ready to Print?", vbInformation, "CPT Group Notes"
Else
fdObj.CreateFolder (strPath)
MsgBox Format(dteStart, "yyyyMM") & "-MonthlyNotes has been created. Ready to Print?", vbInformation, "CPT Group Notes"
End If
ufProgress.Show
'iterating through each patient using For each loop.
For Each strPtName In ptsArray
Application.ScreenUpdating = False
On Error Resume Next
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
Set wd = CreateObject("Word.Application")
End If
On Error GoTo 0
If Dir(ThisWorkbook.Path & PatientReportPath) <> "" Then
pctdone = i / numLastPt
With ufProgress
.LabelCaption.Caption = "Processing Row " & i & " of " & numLastPt & " " & vbCrLf & strPtName
.LabelProgress.Width = pctdone * (.FrameProgress.Width)
End With
Set wdocSource = wd.Documents.Open(ThisWorkbook.Path & PatientReportPath)
strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
wdocSource.MailMerge.MainDocumentType = wdFormLetters
wdocSource.MailMerge.OpenDataSource _
Name:=strWorkbookName, _
AddToRecentFiles:=False, _
Revert:=False, _
Format:=wdOpenFormatAuto, _
Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
SQLStatement:="SELECT * FROM `tblMailMerge` WHERE `Patient Name` = '" & strPtName & "' AND `DATE` BETWEEN #" & dteStart & "# AND #" & dteEnd & "# ORDER BY `DATE` DESC;"
On Error GoTo noprint
If Err.Number = 5631 Then
Err.Clear
GoTo noprint
End If
With wdocSource.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
On Error Resume Next
.Execute Pause:=False
If Err.Number = 5631 Then
Err.Clear
GoTo noprint
End If
'.Execute Pause:=False
End With
'The output document will automatically be the 'active' one
wd.Visible = True
With wd.ActiveDocument
wd.Run ("UniteRecords")
.SaveAs Filename:=strPath & strPtName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
'Close the output file
.Close SaveChanges:=False
End With
noprint:
wdocSource.Close SaveChanges:=False
Set wdocSource = Nothing
Set wd = Nothing
If i = numLastPt Then
Unload ufProgress
wd.Visible = False
Shell "explorer.exe" & " " & strPath, vbNormalFocus
End If
i = i + 1
Else
MsgBox "File ' " & ThisWorkbook.Path & PatientReportPath & "' does not exist!"
End If
Application.ScreenUpdating = True
Next
End Sub
Try:
Sub RunMailMerge()
Application.ScreenUpdating = False
Dim fdObj As Object, wd As Object, wdocSource As Object
Dim strWorkbookName, strPath As String
Dim dteStart As Date, dteEnd As Date
Dim numUnit As Long, i As Long, numLastPt As Long
Dim ptsArray As Variant, strPtName As Variant
Dim pctdone As Single
With ThisWorkbook
If Dir(.Path & PatientReportPath) <> "" Then
strWorkbookName = .FullName
dteStart = .Sheets("Group Dates").Range("F2").Text
dteEnd = .Sheets("Group Dates").Range("F3").Text
strPath = .Path & "\" & Format(dteStart, "YYYYMM") & "-MonthlyNotes\"
ptsArray = .Worksheets("Patients").Range("PtNames").Value
numLastPt = .Worksheets("Patients").Range("PtNames").Count
On Error Resume Next
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then Set wd = CreateObject("Word.Application")
On Error GoTo 0
ufProgress.LabelProgress.Width = 0
'Make new folder if it does not exist
Set fdObj = CreateObject("Scripting.FileSystemObject")
If fdObj.FolderExists(strPath) Then
MsgBox "Found " & Format(dteStart, "yyyyMM") & "-MonthlyNotes. Ready to Print?", vbInformation, "CPT Group Notes"
Else
fdObj.CreateFolder (strPath)
MsgBox Format(dteStart, "yyyyMM") & "-MonthlyNotes has been created. Ready to Print?", vbInformation, "CPT Group Notes"
End If
ufProgress.Show
With wd
.Visible = True
.DisplayAlerts = wdAlertsNone
Set wdocSource = .Documents.Open(strPath & PatientReportPath)
With wdocSource
With .MailMerge
.MainDocumentType = wdFormLetters
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
'iterating through each patient using For each loop.
For Each strPtName In ptsArray
i = i + 1: pctdone = i / numLastPt
With ufProgress
.LabelCaption.Caption = "Processing Row " & i & " of " & numLastPt & " " & vbCrLf & strPtName
.LabelProgress.Width = pctdone * (.FrameProgress.Width)
End With
.OpenDataSource Name:=strWorkbookName, AddToRecentFiles:=False, Revert:=False, _
Format:=wdOpenFormatAuto, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
"Data Source=strWorkbookName;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:="SELECT * FROM `tblMailMerge` WHERE `Patient Name` = '" & strPtName & "' AND `DATE` BETWEEN #" & dteStart & "# AND #" & dteEnd & "# ORDER BY `DATE` DESC"
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
'skip over missing record errors
If Err.Number = 5631 Then
Err.Clear
GoTo NextRecord
End If
With wd.ActiveDocument
wd.Run ("UniteRecords")
.SaveAs Filename:=strPath & strPtName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
'Close the output file
.Close SaveChanges:=False
End With
NextRecord:
Next
End With
.Close SaveChanges:=False
End With
End With
Else
MsgBox "File ' " & .Path & PatientReportPath & "' does not exist!"
End If
End With
Application.ScreenUpdating = True
End Sub
I am really looking forward to get some help because I am trying for so long now...
I want to get a button in excel that starts a word mailmerge and save every letter as a single document. I already found a code, that is doing this fine.
Now comes the problem: I need excel to take different word templates depending on the number in column A (Column A is called Anz). So if column A = 0 there wont be any mail merge (I already managed this by adding "where (Anz>0) to the sql statement.
If column A = 1 excel shall take sb1.docx as the proper mail merge template.
If column A = 2 it shall take sb2.docx and so on.
The numbers go from 0 to 6.
I have no idea how to to this :(
My code so far (that is working but only for the sb1.docx).
Sub RunMerge()
Application.ScreenUpdating = False
Dim StrMMSrc As String, StrMMDoc As String, StrMMPath As String, StrName As String
Dim i As Long, j As Long
Const StrNoChr As String = """*/\:?|"
Dim wdApp As New Word.Application, wdDoc As Word.Document
wdApp.Visible = False
wdApp.DisplayAlerts = wdAlertsNone
StrMMSrc = ThisWorkbook.FullName
StrMMPath = ThisWorkbook.Path & "\"
StrMMDoc = StrMMPath & "sb1.docx"
Set wdDoc = wdApp.Documents.Open(Filename:=StrMMDoc, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With wdDoc
With .MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource Name:=StrMMSrc, ReadOnly:=True, AddToRecentFiles:=False, _
LinkToSource:=False, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
"Data Source=StrMMSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:="SELECT * FROM `Sheet1$` where (Anz>0)"
For i = 1 To .DataSource.RecordCount
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("ID")) = "" Then Exit For
StrName = .DataFields("ID")
End With
.Execute Pause:=False
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next
StrName = Trim(StrName)
With wdApp.ActiveDocument
.SaveAs Filename:=StrMMPath & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
'.SaveAs Filename:=StrMMPath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next i
.MainDocumentType = wdNotAMergeDocument
End With
.Close SaveChanges:=False
End With
wdApp.DisplayAlerts = wdAlertsAll
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = False
End Sub
Try this.
Requirements:
- Each Anz number has it's corresponding template
- The excel spreadsheet has a column called "Anz"
- You have to add the Microsoft Word object library to VBA IDE references
Implementation:
1) Copy and paste the code inside a vba module
2) Customize the code (seek for >>>> customize this <<<<)
Updates:
1) Adjusted the queryString
2) Updated the OpenDataSource code to be more clear
3) Added a fileCounter
Code:
' First you have to configure the settings in each template so the word template filters the data already
' Also add a reference in Excel / VBA IDE to: Microsoft Word [Version] Object Library
Public Sub RunMergeDifferentWordTemplates()
' Declare objects
Dim wordApp As Word.Application
Dim wordTemplate As Word.Document
Dim wordMergedDoc As Word.MailMerge
' Declare other variables
Dim sourceBookPath As String
Dim sheetSourceName As String
Dim excelColumnFilter As String
Dim queryString As String
Dim baseQueryString As String
Dim wordTemplateDirectory As String
Dim wordTemplateFileName As String
Dim wordTemplateFullPath As String
Dim wordOutputDirectory As String
Dim wordOutputFileName As String
Dim wordOutputFullPath As String
Dim idListValues As Variant ' Array
Dim idValue As Integer
Dim idCounter As Integer
Dim recordCounter As Integer
Dim fileCounter As Integer
' >>>>> Customize this <<<<<<
' This would be better to hold it in an Excel structured table
' I'm not including 0 as it's not needed (these would correspon to the anz values).
idListValues = Array(1, 2, 3, 4, 5, 6)
' Excel source settings:
sourceBookPath = ThisWorkbook.FullName
sheetSourceName = "Sheet1" ' The sheet where the data of the mail merge is located
excelColumnFilter = "Anz" ' The column we use to filter the mail merge data
baseQueryString = "SELECT * FROM `" & sheetSourceName & "$` where `" & excelColumnFilter & "` = [columFilterValue] order by `" & excelColumnFilter & "` ASC" ' Would be a better practice to use an Excel structured table: https://support.office.com/en-us/article/overview-of-excel-tables-7ab0bb7d-3a9e-4b56-a3c9-6c94334e492c
' Word settings:
wordTemplateDirectory = ThisWorkbook.Path & "\" ' Include slash at the end
wordTemplateFileName = "sb[columFilterValue].docx" ' Include in the string [columFilterValue] where you want it to be replaced (remember that you have one template for each number)
wordOutputDirectory = ThisWorkbook.Path & "\" ' Include slash at the end
wordOutputFileName = "MailMergeDifferent[columFilterValue]_[Record]" ' Leave the [columFilterValue] and [Record] tags inside the path to identify each document. We'll replace it ahead, dynamically
' Initialize word object
Set wordApp = New Word.Application
wordApp.Visible = True
wordApp.DisplayAlerts = wdAlertsNone
' Loop through each idValue in idListValues
For idCounter = 0 To UBound(idListValues)
' Process each word template
idValue = idListValues(idCounter)
queryString = Replace(baseQueryString, "[columFilterValue]", idValue)
wordTemplateFullPath = wordTemplateDirectory & Replace(wordTemplateFileName, "[columFilterValue]", idValue)
Set wordTemplate = wordApp.Documents.Open(wordTemplateFullPath)
Set wordMergedDoc = wordTemplate.MailMerge
' Process the template's mail merge
With wordMergedDoc
.MainDocumentType = wdFormLetters
.OpenDataSource _
Name:=sourceBookPath, _
ReadOnly:=True, _
Format:=wdOpenFormatAuto, _
Revert:=False, _
AddToRecentFiles:=False, _
LinkToSource:=False, _
Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
"Data Source=" & sourceBookPath & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:=queryString
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
' Each anz have matching records inside the excel worksheet (generate a word file for each one)
For recordCounter = 1 To .DataSource.RecordCount
' Select each record
With .DataSource
.FirstRecord = wordMergedDoc.DataSource.ActiveRecord
.LastRecord = wordMergedDoc.DataSource.ActiveRecord
End With
.Execute Pause:=False
' Add the columnFilterValue and the record identifier to the word file name
' Replace the columnFilterValue and the Record tags
wordOutputFullPath = wordOutputDirectory & Replace(Replace(wordOutputFileName, "[columFilterValue]", idValue), "[Record]", recordCounter)
' Save and close the resulting document
wordApp.ActiveDocument.SaveAs2 Filename:=wordOutputFullPath, FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
wordApp.ActiveDocument.SaveAs2 Filename:=wordOutputFullPath, FileFormat:=wdFormatPDF, AddToRecentFiles:=False
wordApp.ActiveDocument.Close SaveChanges:=False
.DataSource.ActiveRecord = wdNextRecord
' Count files generated
fileCounter = fileCounter + 1
Next recordCounter
End With
' Close word template without saving
wordTemplate.Close False
Next idCounter
' Clean up word objects
wordApp.Visible = False
Set wordApp = Nothing
' Alert process finished
MsgBox fileCounter & " files generated"
End Sub
This is the code that I use to upload file into database using VBA, but this loop can only run once. During the second loop it will give error, the error is
Operation is not allowed in this context
Can anybody suggest me what to do?
The error is in the line adoStream.Type = adTypeBinary
Dim stCon As String 'SQL Connection string
Dim stProcName As String 'Stored Procedure name
Dim strCmd As String
Dim adoStream As Object
Dim adocmd As Object
Dim strFilePath As String
Dim adoCon As Object
Set adoCon = CreateObject("ADODB.Connection")
Set adoStream = CreateObject("ADODB.Stream")
Set adocmd = CreateObject("ADODB.Command")
adoCon.CursorLocation = adUseClient
adoCon.Open "Provider=SQLOLEDB; " & _
"Data Source=#########; " & _
"Initial Catalog=#######;" & _
"User ID=#######; Password=########;"
For Each fl In fld.Files
If fl.name Like Mask Then
strInput = fl.name
strFilePath = fld.path & "\" & fl.name
MsgBox (strFilePath)
adoStream.Type = adTypeBinary
adoStream.Open
adoStream.LoadFromFile strFilePath 'It fails if file is open
With adocmd
.CommandText = "INSERT INTO dbo.coc_upload(Data) " & _
"VALUES (?)"
.CommandType = adCmdText
'---adding parameters
.Parameters.Append .CreateParameter("#Data", adVarBinary, adParamInput, adoStream.Size, adoStream.Read)
'---
End With
adocmd.ActiveConnection = adoCon
adocmd.Execute
adoCon.Close
MsgBox ("Done")
End If
Next