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
Related
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)
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
Im having an issue, I have this Macro to make contracts, it reads the headers on my excel table where I have the information for the contracts (such as Salary, Name, branch offices) and replaces it in a word template.
Also creates a folder with name of the office where the employee works and saves the contratct as PDF with the employee name as filename; because I need to send them to their bosses.
But im having a problem, it does create all the Folders.. but it always ignores the first Branch office (I have them in alphabetical order) and then goes on fine with all the the others.
I ended up creating a new table, create a fake branch office to get the one I need saved.
Can you guys help me find the problem?
Sub CREAR_CARPETAS_X_UNIDAD()
Dim c, lRow As Long
Dim sCarpeta, sContratoModelo, sEmpresa, sNombreApellido, sUnidad As String
Dim sCarpetaUnidad As String
Dim sWord As Object
Dim wb1 As Workbook
Dim WordApp As Word.Application
Dim WordDoc As Object
Application.ScreenUpdating = False
t = Timer
lRow = Cells(Rows.Count, 1).End(xlUp).Row
sCarpeta = Application.ActiveWorkbook.Path
sContratoModelo = sCarpeta & "\CTS_NOVIEMBRE.docx"
'Create Folders for each unit
c = 2
Do
On Error Resume Next
sUnidad = UCase(Range("D" & c).Value)
MkDir sCarpeta & "/" & sUnidad
c = c + 1
Loop While Not c > lRow
'Copy Contract with the client name
Set WordApp = CreateObject("Word.Application")
c = 2
Do
sUnidad = UCase(Range("D" & c).Value)
sNombreApellido = UCase(Range("I" & c).Value)
sCarpetaUnidad = sCarpeta & "/" & sUnidad
WordApp.Visible = True
Set WordDoc = WordApp.Documents.Open(sContratoModelo)
col = 1
Do
With WordDoc.Content.Find
.Text = "OBJ_" & Cells(1, col).Value
.Replacement.Text = Cells(c, col).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
col = col + 1
Loop While Not col > 31
WordDoc.ExportAsFixedFormat OutputFileName:=sCarpetaUnidad & "\" & sNombreApellido & ".pdf", ExportFormat:=wdExportFormatPDF
WordDoc.Close SaveChanges:=wdDoNotSaveChanges
c = c + 1
Loop While Not c > lRow
Application.ScreenUpdating = True
MsgBox ((Timer - t) & " segundos")
End Sub
Are you sure you have a valid folder name for the first Branch office?
Your code could be simplified significantly:
Sub CREAR_CARPETAS_X_UNIDAD()
Application.ScreenUpdating = False
Dim c As Long, t As Single
Dim sCarpeta As String, sContratoModelo As String, sEmpresa As String
Dim sCarpetaUnidad As String, sNombreApellido As String, sUnidad As String
Dim WordApp As Word.Application, WordDoc As Word.Document
t = Timer
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
sCarpeta = ActiveWorkbook.Path
sContratoModelo = sCarpeta & "\CTS_NOVIEMBRE.docx"
'Create Folders for each unit
For c = 2 To Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
sUnidad = UCase(Range("D" & c).Value)
MkDir sCarpeta & "/" & sUnidad
'Copy Contract with the client name
sNombreApellido = UCase(Range("I" & c).Value)
sCarpetaUnidad = sCarpeta & "/" & sUnidad
Set WordDoc = WordApp.Documents.Add(sContratoModelo)
With WordDoc
With .Content.Find
.Wrap = wdFindContinue
For col = 1 To 31
.Text = "OBJ_" & Cells(1, col).Value
.Replacement.Text = Cells(c, col).Value
.Execute Replace:=wdReplaceAll
Next
End With
.SaveAs Filename:=sCarpetaUnidad & "\" & sNombreApellido & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=wdDoNotSaveChanges
End With
Next
Application.ScreenUpdating = True
MsgBox ((Timer - t) & " segundos")
End Sub
You could also use an automated mailmerge. See Run a Mailmerge from Excel, Sending the Output to Individual Files in the Mailmerge Tips and Tricks page at:
https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
I created the macro below (my first time macro ever) to automatically generate PDFs in bulk, creating one per row populating a Word template with the corresponding fields. Now, I need to filter the data to generate PDFs only for the remaining visible rows, but cant figure out what lines of the code to modify to make this happen. I have read about the .SpecialCells(xlCellTypeVisible) but I have no idea where to use it nor if it is even the way to go. I would greatly appreciate some help. Thanks!
Sub PrintPrivacyPolicyDoc_EN()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim objWord As Word.Application, wdDoc As Word.Document
Dim datos(0 To 1, 0 To 9) As String
Set a = Sheets(ActiveSheet.Name)
nom = ActiveWorkbook.Name
pto = InStr(nom, ".")
nomarch = Left(nom, pto - 1)
wArch = ThisWorkbook.Path & "\" & a.Range("B3").Text & ".dotx"
uf = a.Range("A" & Rows.Count).End(xlUp).Row
Set objWord = CreateObject("Word.Application")
objWord.DisplayAlerts = wdAlertsNone
objWord.Visible = True
uf = a.Range("A" & Rows.Count).End(xlUp).Row
Set objWord = CreateObject("Word.Application")
objWord.DisplayAlerts = wdAlertsNone
objWord.Visible = True
For j = 5 To uf
Set wdDoc = objWord.Documents.Open(wArch)
nomfic = nomarch & "_" & a.Cells(j, "A") & "_" & a.Range("C3").Text
rutainf = ThisWorkbook.Path & "\" & "PrivacyPolicy PDFs" & "\" & nomfic & ".pdf"
'Variables to find and text to substitute"
datos(0, 0) = "[Company_Name]"
datos(1, 0) = a.Cells(j, "B")
datos(0, 1) = "[Vat_Number]"
datos(1, 1) = a.Cells(j, "C")
datos(0, 2) = "[URL_Stay]"
datos(1, 2) = a.Cells(j, "D")
datos(0, 3) = "[Update_Date]"
datos(1, 3) = a.Cells(j, "E")
For I = 0 To UBound(datos, 2)
textobuscar = datos(0, I)
objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:=textobuscar
While objWord.Selection.Find.Found = True
objWord.Selection.Text = datos(1, I) 'texto a reemplazar
objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:=textobuscar
Wend
Next I
'Search for the file and delete it before saving the newest verion
If Dir(rutaInf) <> "" Then
Kill rutaInf
End If
'Save file with the designated name
wdDoc.SaveAs Filename:=rutaInf, FileFormat:=wdFormatPDF
'Close Word template without saving changes
wdDoc.Close savechanges:=False
MsgBox ("PDF files were successfully generated"), vbInformation, "NOTIFICATION"
wdDoc.Quit
End Sub
Untested:
Sub PrintPrivacyPolicyDoc_EN()
Dim objWord As Word.Application, wdDoc As Word.Document
Dim nomArch As String, uf As Long, wArch As String
Dim ws As Worksheet, j As Long, nomFic As String, rutaInf As String
Set ws = ActiveSheet
nomArch = Split(ws.Name, ".")(0)
wArch = ThisWorkbook.Path & "\" & ws.Range("B3").Text & ".dotx"
uf = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set objWord = CreateObject("Word.Application")
objWord.DisplayAlerts = wdAlertsNone
objWord.Visible = True
For j = 5 To uf
If Not ws.Rows(j).Hidden Then 'visible rows only
Set wdDoc = objWord.Documents.Open(wArch)
nomFic = nomArch & "_" & ws.Cells(j, "A") & "_" & ws.Range("C3").Text
rutaInf = ThisWorkbook.Path & "\PrivacyPolicy PDFs\" & nomFic & ".pdf"
ReplaceAll wdDoc, "[Company_Name]", ws.Cells(j, "B")
ReplaceAll wdDoc, "[Vat_Number]", ws.Cells(j, "C")
ReplaceAll wdDoc, "[URL_Stay]", ws.Cells(j, "D")
ReplaceAll wdDoc, "[Update_Date]", ws.Cells(j, "E")
If Dir(rutaInf) <> "" Then Kill rutaInf
'Save file with the designated name
wdDoc.SaveAs Filename:=rutaInf, FileFormat:=wdFormatPDF
wdDoc.Close savechanges:=False
End If 'row not hidden
Next j
objWord.Quit 'close Word
End Sub
'Replace all instances of txtFind with txtReplace in doc
Sub ReplaceAll(doc As Word.Document, txtFind As String, txtReplace As String)
With doc.Range.Find
.Text = txtFind
.Replacement.Text = txtReplace
.Replacement.ClearFormatting
.Replacement.Font.Italic = False
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
End Sub
I am using the code below to export a row in an Excel sheet into a Word/pdf file.
It is downloading all non-blank rows.
I want when I select a reference number in a cell dropdown ("CA2"), it only downloads that selected row.
Sub Download_Click()
Dim CustRow, CustCol, LastRow, TemplRow, Reference, RefRow As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim CurDt, LastAppDt As Date
Dim WordDoc, WordApp, OutApp, OutMail As Object
Dim WordContent As Word.Range
With Sheet3
TemplRow = .Range("CI1").Value
TemplName = .Range("BV2").Value
Reference = .Range("CA2").Value
DocLoc = Sheet3.Range("CG2").Value
On Error Resume Next
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
End If
LastRow = .Range("A9999").End(xlUp).Row
For CustRow = 3 To LastRow
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False)
For CustCol = 1 To 70
TagName = .Cells(2, CustCol).Value
TagValue = .Cells(CustRow, CustCol).Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next CustCol
If .Range("BX2").Value = "PDF" Then
FileName = ThisWorkbook.Path & "\" & .Range("B" & CustRow).Value & "_" & .Range("C" & CustRow).Value & ".pdf"
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else
FileName = ThisWorkbook.Path & "\" & .Range("B" & CustRow).Value & "_" & .Range("C" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
Next CustRow
WordApp.Quit
End With
End Sub
As I understand now, your code will export all rows from row 3 to the last row:
For CustRow = 3 To LastRow
If you want only a selected row to be exported, then all you need to do is remove that loop and replace it with a single value, so it only runs once for that value. Remove the above line and replace with this:
CustRow = .Range("CA2").Value
Make sure to remove Next CustRow. Also make sure that cell CA2 contains a numerical value which is a direct reference to the row you need.