admin管理员组

文章数量:1221291

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

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
Share Improve this question edited Feb 7 at 0:31 Ken White 126k15 gold badges235 silver badges463 bronze badges asked Feb 6 at 20:33 olivia bergmannolivia bergmann 1 New contributor olivia bergmann is a new contributor to this site. Take care in asking for clarification, commenting, and answering. Check out our Code of Conduct. 2
  • 1 description = Cells(k, columnIndices(j)).Value how can k be optional here? – Tim Williams Commented Feb 6 at 20:34
  • You need to skip the Do While Loop if Len(description) = 0 . Either use If/Endif or add And eg Do While startPos <= Len(description) And Len(description) > 0. Remove the Optional. – CDP1802 Commented Feb 6 at 21:31
Add a comment  | 

1 Answer 1

Reset to default 0

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

本文标签: excelArgument Not Optional is not working How can I fixStack Overflow