Reputation: 1
I am trying to iteratively generate project sheets row by row in an excel. Some columns have long descriptions so wrote an additional sub function to handle the long text strings. I believe an error occurs in the line below. I added the optional as well in case some rows do not have descriptions.
Sub ReplaceLongText(ByRef doc As Word.Document, Optional ByVal k As Integer)
Full code:
Sub createPDFs()
Dim wd As Word.Application
Dim doc As Word.Document 'Ensure doc is Explicitly Declared as Word.Document
Dim docPath As String
Dim i As Integer ' Explicitly declare i as Integer
' Must Network Sharepoint site to computer to create a working path
docPath = "C:\Users\obergmann\Project Sheet Generation/R&M_ProjectSheetTemplate.docx"
Set wd = New Word.Application
wd.Visible = True
On Error GoTo ErrorHandler
' For loop to iteratively cycle through row numbers:
For i = 8 To 10
' Locate the template
Set doc = wd.Documents.Open(docPath)
' Standard text replacements
With wd.Selection.Find
.Text = "<<Recommendation Number>>"
.Replacement.Text = Cells(i, 1).Value
.Execute Replace:=wdReplaceAll
End With
' I have several more wd.Selection.Find after this
' Call the function to handle long text replacements
Call ReplaceLongText(doc, i)
' Save the Word document
Dim wordFileName As String
wordFileName = ActiveWorkbook.Path & "\" & Cells(i, 2).Value & "_" & Cells(i, 1).Value & ".docx"
doc.SaveAs2 fileName:=wordFileName, FileFormat:=wdFormatDocumentDefault
' export as pdf
doc.ExportAsFixedFormat OutputFileName:=ActiveWorkbook.Path & "\" & Cells(i, 2).Value & "_" & Cells(i, 1).Value & ".pdf", _
ExportFormat:=wdExportFormatPDF
Application.DisplayAlerts = False
doc.Close SaveChanges:=False
Next i
wd.Quit
Application.DisplayAlerts = True
Exit Sub
ErrorHandler:
MsgBox "An error occurred: " & Err.description
If Not doc Is Nothing Then doc.Close False
If Not wd Is Nothing Then wd.Quit
Application.DisplayAlerts = True
End Sub
Function SanitizeFileName(fileName As String) As String
Dim invalidChars As String
invalidChars = ":\/?*""<>|"
Dim i As Integer
For i = 1 To Len(invalidChars)
fileName = Replace(fileName, Mid(invalidChars, i, 1), "_")
Next i
SanitizeFileName = fileName
End Function
`Then here is the next function:
Sub ReplaceLongText(ByRef doc As Word.Document, Optional ByVal k As Integer) ' I think this is the line with issues
Dim placeholders As Variant
Dim columnIndices As Variant
Dim description As String
Dim chunkSize As Integer
Dim startPos As Integer
Dim chunk As String
Dim j As Integer
Dim rng As Range ' Create a range object
' Define placeholders and corresponding column indices
placeholders = Array("<<Description>>", _
"<<Public Health & Safety - Compliance Driven Rationale>>", _
"<<Reliability & Resiliency Rationale>>", _
"<<Community Enrichment/Growth Rationale>>", _
"<<Financial Stewardship Rationale>>", _
"<<Efficiency, Modernization, & Environment Rationale>>", _
"<<Level of Service Rationale>>", _
"<<Additional Prioritization Notes>>", _
"<<Funding Source>>")
columnIndices = Array(3, 12, 13, 14, 15, 16, 17, 18, 27) ' Corresponding Excel column numbers
chunkSize = 255 ' Max characters per chunk
' Loop through all placeholders
For j = LBound(placeholders) To UBound(placeholders)
description = Cells(k, columnIndices(j)).Value
startPos = 1
' Set the range to search in the document
Set rng = doc.Content
With rng.Find
.Text = placeholders(j) ' Set text to find
.Forward = True
.Wrap = wdFindStop
' Execute the search
If .Execute Then
' Set range to the found text
Set rng = doc.Range(rng.Start, rng.End)
rng.Text = "" ' Clear only the placeholder text
' Insert text in chunks
Do While startPos <= Len(description)
chunk = Mid(description, startPos, chunkSize)
rng.InsertAfter Text:=chunk
startPos = startPos + chunkSize
Loop
End If
End With
Next j
End Sub
Upvotes: 0
Views: 42
Reputation: 166585
You can simplify and use one method for all replacements. Here's a basic example:
Sub Tester()
Const docpath As String = "C:\Temp\Template.docx"
Dim ws As Worksheet, rw As Range, doc As Word.Document, placeHolders, j As Long
Dim wd As Word.Application
Set wd = New Word.Application
wd.Visible = True
' Define placeholders and corresponding column indices
' #### a bit easier like this, as one array and loop every second index
placeHolders = Array("<<Recommendation Number>>", 1, _
"<<Description>>", 3, _
"<<Public Health & Safety - Compliance Driven Rationale>>", 12, _
"<<Reliability & Resiliency Rationale>>", 13, _
"<<Community Enrichment/Growth Rationale>>", 14, _
"<<Financial Stewardship Rationale>>", 15, _
"<<Efficiency, Modernization, & Environment Rationale>>", 16, _
"<<Level of Service Rationale>>", 17, _
"<<Additional Prioritization Notes>>", 18, _
"<<Funding Source>>", 27)
Set ws = ActiveSheet
For Each rw In ws.Range("8:10").Rows
Set doc = wd.Documents.Open(docpath)
ResetFindParameters doc.Range 'reset `Find` settings
' Loop through all placeholders
For j = LBound(placeHolders) To UBound(placeHolders) Step 2
'perform the replace
ReplaceAllInDoc doc, CStr(placeHolders(j)), _
CStr(rw.Cells(placeHolders(j + 1)).Value)
Next j
'save the doc here...
doc.Close False
Next rw
End Sub
'In word document `doc`, replace all instances of `findWhat` with `replaceWith`
Sub ReplaceAllInDoc(doc As Word.Document, findWhat As String, replaceWith As String)
Dim rng As Word.Range, col As New Collection
Set rng = doc.Range
With rng.Find
Do While .Execute(findtext:=findWhat)
col.Add rng.Duplicate 'collect found matches
Loop
End With
For Each rng In col 'replace all matches
rng.Text = replaceWith
Next rng
End Sub
'reset any settings from previous `Find` uses...
Sub ResetFindParameters(rng As Word.Range)
With rng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False '<<
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
End Sub
Upvotes: 0