I have this chunk of code :
The macro that calls 2 other macros depending on the cell value is this :
Option Explicit
Function lastRow(col As Variant, Optional wks As Worksheet) As Long
If wks Is Nothing Then
Set wks = ActiveSheet
End If
lastRow = wks.Cells(wks.Rows.Count, col).End(xlUp).Row
End Function
Sub runMacros()
Dim vDat As Variant
Dim i As Long
Dim wks As Worksheet
Set wks = ActiveSheet
With wks
vDat = .Range(.Cells(1, "G"), .Cells(lastRow("G"), "G"))
End With
For i = LBound(vDat) To UBound(vDat)
If vDat(i, 1) = "First" Then
Macro3
Macro1
ElseIf vDat(i, 1) = "Second" Then
Macro3
Macro2
End If
Next i
End Sub
The first macro that is being called is this(Macro3) - it just creates a new folder if it does not exist:
Sub Macro3()
Dim Path As String
Dim Folder As String
Path = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\"
Folder = Dir(Path, vbDirectory)
If Folder = vbNullString Then
MkDir "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\"
End If
End Sub
and then I have this macro:
Sub Macro1()
Application.ScreenUpdating = False
Dim StrMMSrc As String, StrMMDoc As String, StrMMPath As String, StrName As String, SavePath As String, StrFileName As String, MailSubjectName 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
SavePath = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\" 'Name of the folder
StrMMPath = ThisWorkbook.Path & "\"
StrMMDoc = StrMMPath & "RejectionLetterEmployee.docx" 'Name of the word file
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 `Rejection$`"
For i = 1 To .DataSource.RecordCount
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Name")) = "" Then Exit For
StrName = .DataFields("Name") 'File name will be determined by this column name
MailSubjectName = .DataFields("ID")
End With
.Execute Pause:=False
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
MailSubjectName = Replace(MailSubjectName, Mid(StrNoChr, j, 1), "_")
Next
StrName = Trim(StrName)
StrFileName = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\" & StrName
With wdApp.ActiveDocument
'.SaveAs Filename:=StrMMPath & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False 'Save as WORD file(not needed at the moment)
' and/or:
'.SaveAs Filename:=StrMMPath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False 'Save to the folder where the excel sheet exists(not needed)
.SaveAs Filename:=SavePath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False 'Save to the folder that has been created by Path_Exists function
.Close SaveChanges:=False
' Set OutApp = CreateObject("Outlook.Application")
' Set OutMail = OutApp.CreateItem(0)
' On Error Resume Next
' With OutMail
' .To = ""
' .SentOnBehalfOfName = ""
' .CC = ""
' .BCC = ""
' .Subject = "ID" & " " & MailSubjectName & " " & StrName
' .BoDy = ""
' .Attachments.Add StrFileName & ".pdf"
' .Display
'.Send
' End With
' On Error GoTo 0
' Set OutMail = Nothing
' Set OutApp = Nothing
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
Macro1 and Macro2 are the same code but they use a different Word file to create the PDF - Macro1 runs if a cell in "G" column contains the string "first" and Macro2 runs if it contains "second".
The macros create a PDF file and sends it via Outlook.
The problem with Macro1 and Macro2 is that they have a For loop which runs through all rows which basically contradicts what I want to do based on a cell value.
I tried to tweak it a little but since im not familiar that much with VBA I couldnt make it run on the row based on the For loop that runMacros() executes when it calls the 2 other macros.
I only succeeded making it work only on the first row or the last row.
So my question is this : How would I fix Macro1 code to work on a row that runMacros() check.
For example : runMacros() is executed via button.
it checks if G2 cell contains either "first" or "second".
if it contains "first" it will run Macro3 and Macro1.
if it contains "second" it will run Macro3 and Macro2.
runMacros() will then go to the next row, check and execute the macros until it reaches an empty row.
currently Macro1 and Macro2 have a for loop which is wrong because if the G2 contains "first" and G3 contains "second" all the PDF files will be according to Macro2 because it just replaced what Macro1 did
I want Macro1 and Macro2 to follow the row that runMacros() is checking and only execute on that row.
How do I do that?
In answering your question in passing parameters, there are a couple ways to do this. In the first example, create your vDat variable as a Range, then loop over the range and pass a range parameter.
Sub runMacros()
Dim wks As Worksheet
Set wks = ActiveSheet
Dim vDat As Range
With wks
Set vDat = .Range("G1").Resize(lastRow("G"), 1)
End With
Dim i As Long
For i = 1 To vDat.Rows.Count
If vDat.Offset(i, 0).Value = "First" Then
Macro3 vDat.Rows(i)
Macro1 vDat.Rows(i)
ElseIf vDat.Offset(i, 0).Value = "Second" Then
Macro3 vDat.Rows(i)
Macro2 vDat.Rows(i)
End If
Next i
End Sub
Private Sub Macro1(ByRef theRow As Range)
Debug.Print "Macro1 row address = " & theRow.Address
End Sub
Private Sub Macro2(ByRef theRow As Range)
Debug.Print "Macro2 row address = " & theRow.Address
End Sub
Private Sub Macro3(ByRef theRow As Range)
Debug.Print "Macro3 row address = " & theRow.Address
End Sub
But you actually created vDat as an array, so you can just pass the value of that row in the array:
Sub runMacros()
Dim wks As Worksheet
Set wks = ActiveSheet
Dim vDat As Variant
With wks
vDat = .Range("G1").Resize(lastRow("G"), 1).Value
End With
Dim i As Long
For i = LBound(vDat, 1) To UBound(vDat, 1)
If vDat(i, 0) = "First" Then
Macro3 vDat(i, 0)
Macro1 vDat(i, 0)
ElseIf vDat(i, 0) = "Second" Then
Macro3 vDat(i, 0)
Macro2 vDat(i, 0)
End If
Next i
End Sub
Private Sub Macro1(ByVal theRowValue As Variant)
Debug.Print "Macro1 row value = " & theRowValue
End Sub
Private Sub Macro2(ByVal theRowValue As Variant)
Debug.Print "Macro2 row value = " & theRowValue
End Sub
Private Sub Macro3(ByVal theRowValue As Variant)
Debug.Print "Macro3 row value = " & theRowValue
End Sub
What is not clear in your code and question is how the row relates to the DataSource or how you are using it in Macro1 or Macro2. I would also suggest renaming your macros to something more descriptive to what action the macro is performing.
With MailMerge you can create a batch of documents from a datasource.
Using the Status column as a WHERE clause in the datasource SQL allows you to create the
documents with only 2 runs of the same subroutine using a parameter to apply the different template.
Option Explicit
Sub runMacros()
Dim Template1 As String, Template2 As String, Path As String, Folder As String
Template1 = ThisWorkbook.Path & "RejectionLetterEmployee.docx"
Template2 = ThisWorkbook.Path & "RejectionLetterEntrepreneur.docx"
' create path for documents
Path = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\"
Folder = Dir(Path, vbDirectory)
If Folder = vbNullString Then
MkDir Path
End If
' create documents
CreateDocuments "First", Template1, Path
CreateDocuments "Second", Template2, Path
MsgBox "Ended"
End sub
Sub CreateDocuments(Status As String, Template As String, SavePath)
MsgBox "Running macro for Status = [" & Status & "] using " & Template & vbCrLf & _
" into Folder " & SavePath, vbInformation
Const StrNoChr As String = """*./\:?|"
' Paths and Filename
Dim strMMSrc As String, strMMDoc As String, strMMPath As String
Dim StrFileName As String, t0 As Single
t0 = Timer
' open template
Dim wdApp As New Word.Application, wdDoc As Word.Document, i As Integer, j As Integer
Dim strName, MailSubjectName
wdApp.Visible = False
wdApp.DisplayAlerts = wdAlertsNone
Set wdDoc = wdApp.Documents.Open( _
Filename:=Template, _
AddToRecentFiles:=False, _
ReadOnly:=True, _
Visible:=False)
strMMSrc = ThisWorkbook.FullName ' datasource name
With wdDoc.MailMerge
.MainDocumentType = wdFormLetters
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
.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 `Rejection$` WHERE Status = '" & Status & "'"
' confirm to create docs
If vbNo = MsgBox(.DataSource.RecordCount & " documents will be created in " & SavePath & _
", continue ?", vbYesNo, "Confirm") Then
GoTo skip
End If
' create one doc for each record in datasource
For i = 1 To .DataSource.RecordCount
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
strName = Trim(.DataFields("Name"))
MailSubjectName = Trim(.DataFields("ID"))
'Debug.Print "Raw", i, strName, MailSubjectName
If strName = "" Then Exit For
End With
' do merge
.Execute Pause:=False
' construct doc filename to save
' replace illegal characters
For j = 1 To Len(StrNoChr)
strName = Replace(strName, Mid(StrNoChr, j, 1), "_")
MailSubjectName = Replace(MailSubjectName, Mid(StrNoChr, j, 1), "_")
Next
Debug.Print "Cleaned ", i, strName, MailSubjectName
'Save to the folder that has been created by Path_Exists function
StrFileName = SavePath & strName
With wdApp.ActiveDocument
.SaveAs Filename:=SavePath & strName & ".pdf", _
FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next i
.MainDocumentType = wdNotAMergeDocument
End With
MsgBox i - 1 & " documents created in " & SavePath, vbInformation, "Completed in " & Int(Timer - t0) & " secs"
skip:
' cleanup
wdDoc.Close SaveChanges:=False
wdApp.DisplayAlerts = wdAlertsAll
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub
Related
I inherited VBA code that has not worked since my work updated our version of Excel.
The original code looped through all Excel files in a specific folder.
If data in specific cells was blank or a 0, would rename the whole workbook so I would know what files to delete after the fact.
This is the original code. I don't need it to do all of this anymore.
This is part one:
Sub AllFilesWeekly()
Dim folderPath As String
Dim filename As String
Dim wb As Workbook
folderPath = "C:\Users\" & (Environ$("Username")) & "\Desktop\Process Production\" 'change to suit
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
filename = Dir(folderPath & "*.xlsx")
Do While filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & filename)
'Call a subroutine here to operate on the just-opened workbook
Call getmetrics
On Error Resume Next
If Not ActiveWorkbook.Name Like "Audit Hub Report Distribution*" Then
ActiveWorkbook.Close
End If
filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
The second part:
Sub getmetrics()
Dim cell As Range
Dim procstring As String, wbname As String
'Dim OQAYTD As String
Dim OQAMTD As String
Dim ORLYTD As String
Dim ORLMTD As String
Dim DR As String
Dim Audits As Long
Dim permonth As String, peryear As String, permonthrl As String, peryearrl As String
Dim RS As Worksheet, AD As Worksheet, QD As Worksheet, ws As Worksheet, YN As Boolean
For Each ws In Worksheets
If ws.Name = "Audit Detail" Then
YN = True
End If
Next ws
If YN = True Then
ActiveWorkbook.Sheets(2).Name = ("Rep Summary")
Set RS = ActiveWorkbook.Sheets("Rep Summary")
Set AD = ActiveWorkbook.Sheets("Audit Detail")
Set QD = ActiveWorkbook.Sheets("Question Detail")
With Sheets("Process Summary")
For Each cell In Range(Range("A3"), Range("A9999").End(xlUp))
If cell.Value = "Record Level YTD" Then
ORLYTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "YTD Quality Average" Then
OQAYTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "Record Level Quality Average" Then
ORLMTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "Quality Average" Then
OQAMTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "Audits" Then
Audits = Range(cell.Address).Offset(0, 1).Value
End If
End If
End If
End If
End If
Next cell
End With
wbname = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4)
peryear = VBA.Format(OQAYTD, "Percent")
permonth = VBA.Format(OQAMTD, "Percent")
peryearrl = VBA.Format(ORLYTD, "Percent")
permonthrl = VBA.Format(ORLMTD, "Percent")
DR = Right(Sheets("Process Summary").Range("A2").Value, Len(Sheets("Process
Summary").Range("A2").Value) - 12)
RS.Range(RS.Range("A1"), RS.Range("IV1").End(xlToLeft)).AutoFilter
RS.Range(RS.Range("A1"), RS.Range("IV1").End(xlToLeft)).EntireColumn.AutoFit
AD.Range(AD.Range("A1"), AD.Range("IV1").End(xlToLeft)).AutoFilter
AD.Range(AD.Range("A1"), AD.Range("IV1").End(xlToLeft)).EntireColumn.AutoFit
QD.Range(QD.Range("A1"), QD.Range("IV1").End(xlToLeft)).AutoFilter
QD.Range(QD.Range("A1"), QD.Range("IV1").End(xlToLeft)).EntireColumn.AutoFit
Application.DisplayAlerts = False
procstring = wbname & "|" & permonth & "|" & Audits & "|" & peryear & "|" & permonthrl & "|" &
peryearrl & "|" & DR ' & "|" & Users
Debug.Print procstring
Else
Application.DisplayAlerts = False
Dim AWN As String
AWN = ActiveWorkbook.FullName
Debug.Print "Not Audited: " & ActiveWorkbook.Name
ActiveWorkbook.SaveAs "C:\Users\" & (Environ$("Username")) & "\Desktop\Process Production\Delete -" & Second(Now)
Kill AWN
ActiveWorkbook.Close savechanges:=True
Application.DisplayAlerts = True
End If
End Sub
All I need to do is look at cell D3 on the "Process Summary" tab.
If the value in that space is "0.00%", rename the workbook to delete and loop on until all workbooks are looked at.
I do not need to screen print all the extra numbers any more.
Build a Collection of filenames that match the criteria and then use it to rename the files.
Option Explicit
Sub AllFilesWeekly()
Dim folderPath As String, filename As String
Dim wb As Workbook, ws As Worksheet
Dim col As Collection, n As Long
Set col = New Collection
folderPath = "C:\Users\" & (Environ$("Username")) & "\Desktop\Process Production\" 'change to suit
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
' scan folder
filename = Dir(folderPath & "*.xlsx")
Do While filename <> ""
Set wb = Workbooks.Open(folderPath & filename, True, True) ' update links, readonly
For Each ws In wb.Sheets
If ws.Name = "Process Summary" Then
If Format(ws.Range("D3"), "0.00%") = "0.00%" Then
col.Add wb.Name
End If
End If
Next
wb.Close
n = n + 1
filename = Dir
Loop
' result
MsgBox "Files scanned = " & n & vbCrLf & _
"To delete = " & col.Count, vbInformation, folderPath
' rename
If col.Count > 0 Then
If MsgBox("Continue to rename ?", vbYesNo) = vbYes Then
For n = 1 To col.Count
Name folderPath & col(n) As folderPath & "delete_" & col(n)
Next
MsgBox "Rename done"
End If
End If
End Sub
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 want to export the last range and as PDF.
I am using the following code in a userform with checkboxes:
Private Sub CommandButton1_Click()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xArrShetts As Variant
Dim xPDFNameAddress As String
Dim xStr As String
'xArrShetts = Array("test", "Sheet1", "Sheet2") 'Enter the sheet names you will send as pdf files enclosed with quotation marks and separate them with comma. Make sure there is no special characters such as \/:"*<>| in the file name.
xArrShetts = sheetsArr(Me)
For I = 0 To UBound(xArrShetts)
On Error Resume Next
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
Exit Sub
End If
Next
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
'Check if file already exist
xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
vbYesNo + vbQuestion, "File Exists")
If xYesorNo <> vbYes Then Exit Sub
For I = 0 To UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
While Not (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Wend
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard
End If
xArrShetts(I) = xStr
Next
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
.Attachments.Add xArrShetts(I)
Next
If DisplayEmail = False Then
'.Send
End If
End With
End Sub
The code is to determine which worksheets has to be exported as a pdf.
At the same time I'll have to fill in the map where the PDFs can be stored.
After that the code starts an Outlook item and stores the PDFs as attachment.
Private Function sheetsArr(uF As UserForm) As Variant
Dim c As MSForms.Control, strCBX As String, arrSh
For Each c In uF.Controls
If TypeOf c Is MSForms.CheckBox Then
If c.Value = True Then strCBX = strCBX & "," & c.Caption
End If
Next
sheetsArr = Split(Mid(strCBX, 2), ",") 'Mid(strCBX, 2) eliminates the first string character (",")
End Function
The second code is to determine which worksheets are to be exported on the basis of the checkboxes with value true.
Private Sub CommandButton2_Click()
Unload Me
End Sub
Please, replace all code in the used form module with the next one:
Option Explicit
Private Sub CommandButton1_Click()
Dim xSht As Worksheet, xFileDlg As FileDialog, xFolder As String, xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object, xEmailObj As Object, xUsedRng As Range, xArrShetts As Variant
Dim xPDFNameAddress As String, xStr As String, rngExp As Range, lastRng As Range
xArrShetts = sheetsArr(Me) 'do not forget the keep the sheetsArr function...
For I = 0 To UBound(xArrShetts)
On Error Resume Next
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
Exit Sub
End If
Next
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
'Check if file already exist
xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
vbYesNo + vbQuestion, "File Exists")
If xYesorNo <> vbYes Then Exit Sub
For I = 0 To UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
While Not (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Wend
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
Set lastRng = xSht.Range("A" & xSht.Rows.Count).End(xlUp) 'determine the last cell in A:A
Set rngExp = xSht.Range(lastRng.Offset(-26), lastRng.Offset(, 7)) 'create the range to be exported as pdf
rngExp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard 'export the range, not the sheet
End If
xArrShetts(I) = xStr
Next
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.cc = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
.Attachments.Add xArrShetts(I)
Next
If .DisplayEmail = False Then
'.Send
End If
End With
End Sub
Private Function sheetsArr(uF As UserForm) As Variant
Dim c As MSForms.Control, strCBX As String, arrSh
For Each c In uF.Controls
If TypeOf c Is MSForms.CheckBox Then
If c.Value = True Then strCBX = strCBX & "," & c.Caption
End If
Next
sheetsArr = Split(Mid(strCBX, 2), ",") 'Mid(strCBX, 2) eliminates the first string character (",")
End Function
Private Sub CommandButton2_Click()
Unload Me
End Sub
Please, send some feedback after testing it.
I have been using a code which uses mailmerge from the excel sheet to my word template and then proceeds to save all the rows in my excel sheet to PDF(in the word template of course). - The code works perfectly fine.
The code was taken from this forum :
https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
How my Excel sheet looks like :
A1-E1 = Headers
A2-E2 = data
A3-E3 = data
A4-E4 = data
and so on...
How the code currently works :
The code saves all rows of data from the excel sheet into my word template(with mailmerge) and then into PDFs.
My goal :
I want to change the code so it only saves the last row of data in the excel sheet into my word template(with mailmerge) and then into to PDF.
Sub RunMerge()
' Sourced from: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
' Note: this code requires a reference to the Word object model to be set, via Tools|References in the VBE.
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 & "MailMergeDocument.doc"
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$`"
For i = 1 To .DataSource.RecordCount
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Name")) = "" Then Exit For
StrName = .DataFields("Name")
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
'Add the name to the footer
'.Sections(1).Footers(wdHeaderFooterPrimary).Range.InsertBefore StrName
'.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
Thanks in advance.
Replace:
For i = 1 To .DataSource.RecordCount
with:
i = .DataSource.RecordCount
or, if there are rows in use below that in other columns:
i = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row - 1
where 'A' is any column not containing data below the last record and delete both:
If Trim(.DataFields("Name")) = "" Then Exit For
and:
Next i
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