Extract comments from multiple word docs into Excel - excel

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

Related

Is there a way to export associated comments and replies (comment children) from Microsoft Word to Excel?

I already have this existing code which works great for exporting comments and responses, but it doesn't link them in anyway. Is there a way to modify the code so that when comments are exported comments and replies/responses are linked/identified so you can trace which comments are in response to what? TYIA
Sub ExportComments()
' Note: A reference to the Microsoft Excel # Object Library is required, set via Tools|References in the Word VBE.
Dim StrCmt As String, StrTmp As String, i As Long, j As Long, xlApp As Object, xlWkBk As Object
StrCmt = "Page,Line,Author,Date & Time,Comment,Reference Text"
StrCmt = Replace(StrCmt, ",", vbTab)
With ActiveDocument
' Process the Comments
For i = 1 To .Comments.Count
With .Comments(i)
StrCmt = StrCmt & vbCr & .Reference.Information(wdActiveEndAdjustedPageNumber) & vbTab
StrCmt = StrCmt & .Reference.Information(wdFirstCharacterLineNumber) & vbTab & .Author & vbTab
StrCmt = StrCmt & .Date & vbTab & Replace(Replace(.Range.Text, vbTab, "<TAB>"), vbCr, "<P>")
StrCmt = StrCmt & vbTab & Replace(Replace(.Reference.Text, vbTab, "<TAB>"), vbCr, "<P>")
End With
Next
End With
' Test whether Excel is already running.
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
'Start Excel if it isn't running
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
MsgBox "Can't start Excel.", vbExclamation
Exit Sub
End If
End If
On Error GoTo 0
With xlApp
Set xlWkBk = .Workbooks.Add
' Update the workbook.
With xlWkBk.Worksheets(1)
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:D").AutoFit
End With
' Tell the user we're done.
MsgBox "Workbook updates finished.", vbOKOnly
' Switch to the Excel workbook
.Visible = True
End With
' Release object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
End Sub
Replace .Reference.Text with .Scope.Text

How can I extract data from multiple Word documents to excel rows based on keywords using VBA?

I got this VBA code from #macropod to extract data from various Word files from the folder that is in the "strFolder" variable of the VBA code below, but I can only extract data that is in front of the keyword, as in the term "TRABALHO" (attached image) the VBA code extracts the content from the front, but I can't extract data from below, for example in: "CONSTATAÇÃO" I can't extract the text from below, if anyone can help me I would appreciate it. Just below I also put a capture of the document that I have to use to extract the data.
IMAGE - Word Document
Sub GetData()
'Note: this code requires a reference to the Word object model.
'See under the VBA Editor's Tools|References.
Application.ScreenUpdating = False
Dim WkSht As Worksheet, r As Long, c As Long
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim strFile As String, strFolder As String, strOut As String, StrFnd
strFolder = "C:\Users\" & Environ("UserName") & "\Desktop\Macro VBA - Trabalhos Sequenciais\Trabalhos\"
StrFnd = Array("", "", "TRABALHO", "SEQUENCIAL", "REGISTRO", "DATA DA IMPLEMENTAÇÃO", "PRAZO PARA EFETIVAÇÃO", _
"DATA DA EFETIVAÇÃO", "RESPONSÁVEL PELA ANÁLISE", "REVISOR", "CONSTATAÇÃO")
Set WkSht = ActiveSheet: r = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
r = r + 1
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
WkSht.Cells(r, 1).Value = Split(strFile, ".doc")(0)
With wdDoc
For c = 2 To UBound(StrFnd)
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Text = ""
.Forward = True
.Format = False
.MatchCase = False
.MatchWildcards = False
.Text = StrFnd(c)
.Wrap = wdFindContinue
.Execute
End With
If .Find.Found = True Then
.End = .Paragraphs(1).Range.End
.Start = .Start + Len(StrFnd(c))
strOut = Trim(Replace(Replace(Replace(Split(.Text, vbCr)(0), vbTab, " "), Chr(11), " "), Chr(160), " "))
Do While strOut = ""
.Collapse wdCollapseEnd
.MoveEnd wdParagraph, 1
strOut = Trim(Replace(Replace(Replace(Split(.Text, vbCr)(0), vbTab, " "), Chr(11), " "), Chr(160), " "))
Loop
WkSht.Cells(r, c).Value = strOut
End If
End With
Next
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub
From what I can tell, your data are in various cells in the first 3 tables in the document. In that case, you need something like:
Sub GetData()
'Note: this code requires a reference to the Word object model.
'See under the VBA Editor's Tools|References.
Application.ScreenUpdating = False
Dim WkSht As Worksheet, r As Long, c As Long
Dim wdApp As New Word.Application, wdDoc As Word.Document, wdRng As Word.Range
Dim strFile As String, strFolder As String
strFolder = "C:\Users\" & Environ("UserName") & "\Desktop\Macro VBA - Trabalhos Sequenciais\Trabalhos\"
Set WkSht = ActiveSheet: r = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
r = r + 1: c = 1
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
WkSht.Cells(r, c).Value = Split(strFile, ".doc")(0)
With wdDoc
With .Tables(1)
Set wdRng = .Cells(1, 2).Range: c = c + 1
WkSht.Cells(r, c).Value = Split(Rng.Text, vbCr)(0)
Set wdRng = .Cells(1, 2).Range: c = c + 1
WkSht.Cells(r, c).Value = Split(Rng.Text, vbCr)(0)
Set wdRng = .Cells(1, 3).Range: c = c + 1
WkSht.Cells(r, c).Value = Split(Rng.Text, vbCr)(0)
End With
With .Tables(2)
Set wdRng = .Cells(1, 2).Range: c = c + 1
WkSht.Cells(r, c).Value = Split(Rng.Text, vbCr)(0)
Set wdRng = .Cells(1, 4).Range: c = c + 1
WkSht.Cells(r, c).Value = Split(Rng.Text, vbCr)(0)
Set wdRng = .Cells(2, 2).Range: c = c + 1
WkSht.Cells(r, c).Value = Split(Rng.Text, vbCr)(0)
Set wdRng = .Cells(3, 2).Range: c = c + 1
WkSht.Cells(r, c).Value = Split(Rng.Text, vbCr)(0)
Set wdRng = .Cells(4, 2).Range: c = c + 1
WkSht.Cells(r, c).Value = Split(Rng.Text, vbCr)(0)
End With
With .Tables(3)
Set wdRng = .Cells(2, 1).Range: c = c + 1
WkSht.Cells(r, c).Value = Split(Rng.Text, vbCr)(0)
End With
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
wdApp.Quit
Set wdRng = Nothing: Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub
I can answer how to extract data from multiple word files and write it to text file.
Following is the code to extract multiple word files from multiple folders and sub folders
import glob
import docx2txt as d2t
input_dir=r"D:\Doc scraping\xyz"
filepaths=list(glob.glob(input_dir+"\**\*.docx", recursive=True))
def extract_data_from_docx(path_to_file, get_text=False):
text = d2t.process(path_to_file)
if(get_text): #Defining a function to extract text from docx file
return text
data=""
for filepath in filepaths:
data = data + extract_data_from_docx(filepath, get_text=True)
print(data)

Insert adjustable table in Word document from Excel

I will have two situations either:
Otherwise the first cell, will contain more values separated by ";" as follows:
These situations should result in different tables which should be inserted in a pre-existing Word document I open with the VBA from Excel.
The resulting tables are shown below:
I just inserted a "fixed" table in the Word document and replace the inside values, this isn't sufficient anymore.
This is the code I use to open a Word document and replace certain words and save the newly made Word documents as a new file in both docx and pdf format:
Sub Sample()
Const wdFindContinue As Long = 1
Const wdReplaceAll As Long = 2
Const StrNoChr As String = """*./\:?|"
Dim oWordApp As Object, oWordDoc As Object, rngStory As Object
Dim sFolder As String, strFilePattern As String
Dim strFileName As String, sFileName As String
Dim cant As Integer
Dim tex As String
Dim max As Integer
Dim total As Integer
Dim final As Integer
sFolder = "C:\Users\name\folder\"
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = False
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Data")
last_row = Application.WorksheetFunction.CountA(sh.Range("A:A"))
For i = 2 To last_row
sFileName = sFolder & "wordfile.docx"
Set oWordDoc = oWordApp.Documents.Open(sFileName)
For Each rngStory In oWordDoc.StoryRanges
With rngStory.Find
If sh.Range("C" & i).Value <> "" Then
.Text = "_Name1"
.Replacement.Text = sh.Range("C" & i).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End If
If sh.Range("D" & i).Value <> "" Then
.Text = "_Name2"
.Replacement.Text = sh.Range("D" & i).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End If
End With
Next
StrName = Sheets(1).Cells(i, 2)
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next j
StrName = Trim(StrName)
With oWordDoc
.SaveAs Filename:=sFolder & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
'.SaveAs Filename:=sFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.ExportAsFixedFormat sFolder & StrName & ".pdf", 17
.Close SaveChanges:=False
End With
Next i
oWordApp.Quit
Set oWordDoc = Nothing
Set oWordApp = Nothing
MsgBox "Succes"
End Sub
The code isn't relevant for the specific problem, but may give some inspiration or other ideas.
EDIT:
I tried with this:
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=2, NumColumns:= 4
As suggested by MacroPod, but it doesn't work.
For example, assuming the basic tables are already there and you have code to populate the rows with the pre-processed data:
Sub Demo()
Dim oWdApp As Object, oWdDoc As Object, oWdRng As Object, oWdTbl As Object
Dim sFolder As String, sFileName As String, StrTxt As String
Dim last_row As Long, r As Long, c As Long, i As Long, j As Long
Const wdFindContinue As Long = 1: Const wdReplaceAll As Long = 2
Const wdFormatXMLDocument As Long = 12: Const wdFormatPDF As Long = 17
Const StrNoChr As String = """*./\:?|"
sFolder = "C:\Users\name\folder\"
Dim sh As Worksheet: Set sh = ThisWorkbook.Sheets("Data")
last_row = Application.WorksheetFunction.CountA(sh.Range("A:A"))
On Error Resume Next
Set oWdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set oWdApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWdApp.Visible = False
For i = 2 To last_row
sFileName = sFolder & "wordfile.docx"
Set oWdDoc = oWdApp.Documents.Add(sFileName)
With oWdDoc
For Each oWdRng In .StoryRanges
With oWdRng.Find
If sh.Range("C" & i).Value <> "" Then
.Text = "_Name1"
.Replacement.Text = sh.Range("C" & i).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End If
If sh.Range("D" & i).Value <> "" Then
.Text = "_Name2"
.Replacement.Text = sh.Range("D" & i).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End If
End With
Next
For Each oWdTbl In .Tables
With oWdTbl
For r = .Rows.Count To 2 Step -1
For c = 1 To .Rows(r).Cells.Count Step 2
StrTxt = Split(.Cell(r, c).Range.Text, vbCr)(0)
If InStr(StrTxt, ";") > 0 Then
For j = 1 To UBound(Split(StrTxt, ";"))
If r = .Rows.Count Then
.Rows.Add
Else
.Rows.Add .Rows(r + 1)
End If
.Cell(r + j, c).Range.Text = Split(Trim(Split(StrTxt, ";")(j)), " ")(0)
.Cell(r + j, c + 1).Range.Text = Replace(Replace(Split(Trim(Split(StrTxt, ";")(j)), " ")(1), ")", ""), "(", "")
Next
End If
If InStr(StrTxt, " ") > 0 Then
.Cell(r, c).Range.Text = Split(Trim(Split(StrTxt, ";")(0)), " ")(0)
.Cell(r, c + 1).Range.Text = Replace(Replace(Split(Trim(Split(StrTxt, ";")(0)), " ")(1), ")", ""), "(", "")
End If
Next
Next
End With
Next
StrName = Sheets(1).Cells(i, 2).Text
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next j
StrName = Trim(StrName)
.SaveAs Filename:=sFolder & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
.SaveAs Filename:=sFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next i
oWdApp.Quit
Set oWordDoc = Nothing: Set oWdApp = Nothing: Set oWdRng = Nothing: Set oWdTbl = Nothing: Set sh = Nothing
MsgBox "Succes"
End Sub

A macro that calls 2 macros depending on the cell value

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

Create Hyperlink for row each entry in Excel Sheet but just in specific columns

In the attached code, I am looping through all the Excel files in a folder and searching for a keyword. I then extract the file name, sheet number, cell number and row data and place that information into a newly created spreadsheet called "Summary". How do I hyperlink just the worksheet # and cell # columns (Columns B and C) to point to the exact file, page, cell where the newly created row entry came from?
Here is a snippet of my code:
Sub SearchFolders()
'UpdatebySUPERtoolsforExcel2016
...
Dim xOut As Worksheet
Dim xWb As Workbook
Dim xWk As Worksheet
Dim xRow As Long
Dim xFound As Range
Dim xStrAddress As String
Dim xCount As Long
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a forlder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
...
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
Set xOut = wsReport
xRow = 1
With xOut
.Cells(xRow, 1) = "Workbook"
.Cells(xRow, 2) = "Worksheet"
.Cells(xRow, 3) = "Cell"
.Cells(xRow, 4) = "Test"
...
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xFld = xFso.GetFolder(xStrPath)
xStrFile = Dir(xStrPath & "\*.xlsx")
Do While xStrFile <> ""
Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
For Each xWk In xWb.Worksheets
Set xFound = xWk.UsedRange.Find(xStrSearch, LookIn:=xlValues)
If Not xFound Is Nothing Then
xStrAddress = xFound.Address
End If
Do
If xFound Is Nothing Then
Exit Do
Else
xCount = xCount + 1
xRow = xRow + 1
.Cells(xRow, 1) = xWb.Name
.Cells(xRow, 2) = xWk.Name
.Cells(xRow, 3) = xFound.Address
WriteDetails rCellwsReport, xFound
End If
Set xFound = xWk.Cells.FindNext(After:=xFound)
Loop While xStrAddress <> xFound.Address
Next
xWb.Close (False)
xStrFile = Dir
Loop
.Columns("A:I").EntireColumn.AutoFit
.Range("A1:A" & xCount + 1).Rows.EntireRow.AutoFit
End With
MsgBox xCount & "cells have been found", , "SUPERtools for Excel"
ExitHandler:
Set xOut = Nothing
...
Application.ScreenUpdating = xUpdate
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
Private Sub WriteDetails(ByRef xReceiver As Range, ByRef xDonor As Range)
xReceiver.Value = xDonor.Parent.Name
xReceiver.Offset(, 1).Value = xDonor.Address
xDonor.EntireRow.Resize(, 100).Copy xReceiver.Offset(, 2)
Set xReceiver = xReceiver.Offset(1)
End Sub
To create a hyperlink to an external workbook/worksheet/cell you need to understand how the link forms
See this example
Let's say you have a file Joe.Xlsx in C:\. And let's assume that it has a worksheet called Sheet1 and you want to hyperlink to cell A1 of that sheet.
So in your current workbook, you will type
=HYPERLINK("[C:\Joe.xlsx]Sheet1!A1","CLICK HERE")
So if you break it, it will look like this.
Dim FileName As String
Dim SheetName As String
Dim CellAddress As String
FileName = "C:\Joe.xlsx"
SheetName = "Sheet1"
CellAddress = "A1"
If InStr(1, SheetName, " ") Then SheetName = "'" & SheetName & "'"
Range("A1").Formula = "=HYPERLINK(" & Chr(34) & "[" & _
FileName & _
"]" & _
SheetName & _
"!" & _
CellAddress & _
Chr(34) & "," & Chr(34) & _
"CLICK HERE" & Chr(34) & ")"
Simply use this in your code in a loop and create the hyperlinks

Resources