Define range within word table between specific text instance and end of cell content

Thom.Simmo · #1 03-03-2022, 05:13 AM

Hi

Not entirely sure if this falls within Word VBA or Excel VBA as I am attempting to put together a script that copy's the content of a pivot table into word and then format it. The script is run from within excel but opens a new word document and formats the table within word.

The script is admittedly cobbled together from various examples.

I have attached 2 examples of the table below. Table eg1 shows the table as it arrives from excel

Table eg1.JPG

Table eg2 is an example of how I am trying to format the table contents.

Table eg2.JPG

The text that I am attempting to italicise is in the cells of the third column. The words Recommended Action will always be imported from excel and I would like to italicise these words and everything following within the cell.

I am having trouble defining the range which I am trying to italicise. I have tried various permutations and the current version is below,

Code:

'Find and italiscise text folowing "Reccomended Action"
    pos1 = InStr(oRng, "Reccomended Action")
    pos2 = oRow.Cells(3).Range.End
        rngFormat = oRng.Range(Start:=pos1, End:=pos2)
        
        rngFormat.Italic = True

I have included all the code I am using below as I am not sure if there may be some issues to do with making edits in word with VBA run from within Excel.

Code:

Sub ExcelRangeToWord()

'Includes  multiple edits and adaptations from original source
'PURPOSE: Copy/Paste An Excel Table Into a New Word Document
'NOTE: Must have Word Object Library Active in Order to Run _
  (VBE > Tools > References > Microsoft Word 12.0 Object Library)
'SOURCE: www.TheSpreadsheetGuru.com

Dim tbl As PivotTable
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table

'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False

'Copy Range from Excel
  Set tbl = ThisWorkbook.Worksheets("InspectionPivot").PivotTables("InspectionPivot")

'Create an Instance of MS Word
  On Error Resume Next
    
    'Is MS Word already opened?
      Set WordApp = GetObject(class:="Word.Application")
    
    'Clear the error between errors
      Err.Clear

    'If MS Word is not already open then open MS Word
      If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")
    
    'Handle if the Word Application is not found
      If Err.Number = 429 Then
        MsgBox "Microsoft Word could not be found, aborting."
        GoTo EndRoutine
      End If

  On Error GoTo 0
  
'Make MS Word Visible and Active
  WordApp.Visible = True
  WordApp.Activate
    
'Create a New Document
  Set myDoc = WordApp.Documents.Add
  
'Copy Excel Table Range
  tbl.TableRange2.Copy

'Paste Table into MS Word
  myDoc.Paragraphs(1).Range.PasteExcelTable _
    LinkedToExcel:=False, _
    WordFormatting:=False, _
    RTF:=False
  
'set column widths
Set WordTable = myDoc.Tables(1)
    With WordTable
                WordTable.Columns(1).Width = CentimetersToPoints(0.5)
                WordTable.Columns(2).Width = CentimetersToPoints(3)
                WordTable.Columns(3).Width = CentimetersToPoints(11.5)
                WordTable.Columns(4).Width = CentimetersToPoints(1)
    End With

'delete empty rows
    With WordTable
        noOfCol = WordTable.Range.Rows(1).Cells.Count
                For i = .Rows.Count To 1 Step -1
                    With .Rows(i)
                        If Len(.Range) = noOfCol * 2 + 2 Then .Delete
                    End With
                Next i
    End With

'Insert report refrence section number before item numbers

    Dim SecNum As String
    Dim RefCell As Cell
        SecNum = "6."
    
        For Each RefCell In WordTable.Range.Columns(1).Cells
          RefCell.Range.InsertBefore (SecNum)
         Next RefCell

'format report text in column 3
   
Dim oTbl As Table
Dim oRow As Row
Dim oRng As Range
Dim rngFormat As Word.Range
Dim WrdFind As Find

Dim pos1 As Long
Dim pos2 As Long

Set oTbl = ActiveDocument.Tables(1)

For Each oTbl In ActiveDocument.Tables
  
  For Each oRow In WordTable.Rows
  
    Set oRng = oRow.Cells(3).Range
    
    'Replace line brakes with paragraph
    oRow.Cells(3).Range = Replace(oRow.Cells(3).Range.Text, vbVerticalTab, vbCrLf)
    
    'Make first para bold
    oRow.Cells(3).Range.Paragraphs(1).Range.Bold = True
    
    'Find and italiscise text folowing "Reccomended Action"
    pos1 = InStr(oRng, "Reccomended Action")
    pos2 = oRow.Cells(3).Range.End
        rngFormat = oRng.Range(Start:=pos1, End:=pos2)
        
        rngFormat.Italic = True
   
     
  Next
  
  
Next

EndRoutine:


'Optimize Code
  Application.ScreenUpdating = True
  Application.EnableEvents = True

'Clear The Clipboard
  Application.CutCopyMode = False

End Sub

Any help will be greatly appreciated,

Cheers
Thom

macropod · #2 03-06-2022, 04:14 AM

Your code could be much improved. For example:

Code:

Sub ExcelRangeToWord()
'Initialize
Application.ScreenUpdating = False
Dim WdApp As Word.Application, WdDoc As Word.Document, WdTbl As Word.Table, i As Long
Const SecNum As String = "6."

'Instantiate Word
Set WdApp = CreateObject("Word.Application")

With WdApp
  'Make MS Word Visible
  .Visible = True
  'Create a New Document
  Set WdDoc = .Documents.Add
  'Copy Excel Table Range
  ThisWorkbook.Worksheets("InspectionPivot").PivotTables("InspectionPivot").TableRange2.Copy
  With WdDoc
    'Paste Table into MS Word
    .Paragraphs(1).Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
    Set WdTbl = .Tables(1)
    'Set Table column widths
    With WdTbl
      .Rows(1).HeadingFormat = True
      .Rows.HeightRule = wdRowHeightAuto
      .Columns(1).Width = WdApp.CentimetersToPoints(0.5)
      .Columns(2).Width = WdApp.CentimetersToPoints(3)
      .Columns(3).Width = WdApp.CentimetersToPoints(11.5)
      .Columns(4).Width = WdApp.CentimetersToPoints(1)
  
      For i = .Rows.Count To 2 Step -1
        With .Rows(i)
          If Len(.Range.Text) <= .Cells.Count * 3 + 2 Then
            'delete empty rows
            .Delete
          Else
            'Insert report ref section # before item #
            .Cells(1).Range.InsertBefore (SecNum)
          End If
        End With
      Next i
    End With
    
    With .Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "Recommended Action"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
      End With
      Do While .Find.Execute
        If .Information(wdWithInTable) = True Then
          .End = .Cells(1).Range.End - 1
          .Style = wdStyleEmphasis
        End If
        .Collapse wdCollapseEnd
      Loop
    End With
  End With
  'Display Document
  .Activate
End With
'Clean Up
Set WdTbl = Nothing: Set WdDoc = Nothing: Set WdApp = Nothing
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Thom.Simmo · #3 03-08-2022, 08:30 AM

Thankyou for taking the time to go through this, really appreciated.

I had assumed that no one had time to post a reply so continued working on the problem on my own. I did managed to reach a solution which I was just coming back to post although it is admittedly a bit of a car crash by comparison with what you have offered. I have posted it below for completeness.

I'd like to use your edits to add in additional formatting to other elements of the text within the cell.

Code:

Sub ExcelRangeToWord()

Dim tbl As PivotTable
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table

'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False

'Copy Range from Excel
  Set tbl = ThisWorkbook.Worksheets("InspectionPivot").PivotTables("InspectionPivot")

'Create an Instance of MS Word
  On Error Resume Next
    
    'Is MS Word already opened?
      Set WordApp = GetObject(class:="Word.Application")
    
    'Clear the error between errors
      Err.Clear

    'If MS Word is not already open then open MS Word
      If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")
    
    'Handle if the Word Application is not found
      If Err.Number = 429 Then
        MsgBox "Microsoft Word could not be found, aborting."
        GoTo EndRoutine
      End If

  On Error GoTo 0
  
'Make MS Word Visible and Active
  WordApp.Visible = True
  WordApp.Activate
    
'Create a New Document
  Set myDoc = WordApp.Documents.Add
  
'Copy Excel Table Range
  tbl.TableRange2.Copy

'Paste Table into MS Word
  myDoc.Paragraphs(1).Range.PasteExcelTable _
    LinkedToExcel:=False, _
    WordFormatting:=False, _
    RTF:=False
  
'set column widths
Set WordTable = myDoc.Tables(1)
    With WordTable
                WordTable.Columns(1).Width = CentimetersToPoints(0.5)
                WordTable.Columns(2).Width = CentimetersToPoints(3)
                WordTable.Columns(3).Width = CentimetersToPoints(11.5)
                WordTable.Columns(4).Width = CentimetersToPoints(1)
    End With

'delete empty rows
    With WordTable
        noOfCol = WordTable.Range.Rows(1).Cells.Count
                For i = .Rows.Count To 1 Step -1
                    With .Rows(i)
                        If Len(.Range) = noOfCol * 2 + 2 Then .Delete
                    End With
                Next i
    End With

'Insert report refrence section number before item numbers

    Dim SecNum As String
    Dim RefCell As Cell
        SecNum = "6."
    
        For Each RefCell In WordTable.Range.Columns(1).Cells
          RefCell.Range.InsertBefore (SecNum)
         Next RefCell

'format report text in column 3
   
Dim oTbl As Table
Dim oRow As Row
Dim oRng As Word.Range
Dim rngFormat As Word.Range
Dim bltFormat As Word.Range
Dim Fnd As Boolean
Dim Fnd2 As Boolean

Dim WrdFind As Find

Dim pos1 As Long
Dim pos2 As Long

Set oTbl = ActiveDocument.Tables(1)

For Each oTbl In ActiveDocument.Tables





         
  For Each oRow In WordTable.Rows
  
    Set oRng = oRow.Cells(3).Range
    
    'Replace line brakes with paragraph and set spacing after to 0
    oRow.Cells(3).Range = Replace(oRow.Cells(3).Range.Text, vbVerticalTab, vbCrLf)
    oRow.Cells(3).Range.ParagraphFormat.SpaceAfter = 0
    
    'Make first para bold
    oRow.Cells(3).Range.Paragraphs(1).Range.Bold = True
    
    'Find and italiscise text folowing "Reccomended Action"
   Set rngFormat = oRow.Cells(3).Range
        With rngFormat.Find
        .ClearFormatting
        .Execute FindText:="Recommended Action", Forward:=False, _
                 Format:=False, Wrap:=wdFindStop
        Fnd = .Found
    End With
   
    If Fnd = True Then
         With rngFormat
             .MoveEnd Unit:=wdCell, Count:=1
             
             With .Font
                 .Italic = True
             End With
         End With
     End If
   
       
    'Bullet non bold or italic text
    Set bltFormat = oRow.Cells(3).Range
        With bltFormat.Find
        .Execute FindText:="Recommended Action", Forward:=False, _
                 Format:=False, Wrap:=wdFindStop
        Fnd = .Found
    End With
   
    If Fnd = True Then
         With bltFormat
               .MoveEnd Unit:=wdParagraph, Count:=-1
               .MoveStart Unit:=wdCell, Count:=-1
               .MoveStart Unit:=wdParagraph, Count:=1
             bltFormat.ListFormat.ApplyBulletDefault
         End With
     End If
   
  Next
Next

EndRoutine:


'Optimize Code
  Application.ScreenUpdating = True
  Application.EnableEvents = True

'Clear The Clipboard
  Application.CutCopyMode = False

End Sub

Thankyou for your help it has been really useful to compare what I have cobbled together with what you have written.

Cheers
Thom

Thom.Simmo · #4 03-09-2022, 08:49 AM

Thanks for your reply's,

I thought it might be useful to upload the spread sheet the code is run from, unfortunately it is too large. I have copied some sample data into a separate sheet and attached it if it is any use in helping to get to the bottom of what is going on.

SampleData.xlsx

It would be great to get this running properly as I believe Macropod's code will be much more efficient to run than my own.

Thanks
Thom

Thom.Simmo · #5 03-09-2022, 09:13 AM

Hi,

As part of a project I am working I am attempting to split a table into a series of separate tables based on a comparison of the first four characters within a column of cells.

A separate problem to do with formatting text in the same project is discussed here

The code below is extracted from the wider project which copies a pivot table from excel into word and formats it for a report.

The first column of the table contains a reference number which is formatted 6.X.X . Depending on the length of the report this number may end up being 6.XX.X . I would like to split the table into separate tables at every row in which the numbers between the bullet points change.

eg 6.1.1, 6.1.2, 6.1.3, Table split, 6.2.1, 6.2.2, table split, 6.3.1, etc

An image of the table is attached below
Table eg3.JPG

Currently the code I have put together splits the table at all rows within the table and try as I might I don't seem to be setting the ranges for comparison correctly.

Code:

 Dim eRow As Row
        Dim A As Long
        Dim WordTable As Word.Table
        Dim RefRange1 As Word.Range
        Dim RefRange2 As Word.Range
        Dim TxtRange1 As Word.Range
        Dim TxtRange2 As Word.Range
        
        A = 1
             Do While A > 0

                On Error Resume Next
                For Each eRow In WordTable.Rows
                 
                    Set RefRange1 = eRow.Cells(1).Range
                    Set RefRange2 = RangeRef1.Rows(-1).Cells(1).Range
                    Set TxtRange1 = RefRange1.Cells(1).Range.Characters(1)
                    TxtRange1.End = RefRange1.Cells(1).Range.Characters(4)
                    Set TxtRange2 = RefRange2.Cells(1).Range.Characters(1)
                    TxtRange1.End = RefRange2.Cells(1).Range.Characters(4)
                    
                    
                    If TxtRange1.IsEqual(Range:=TxtRange2) = False Then
                       A = eRow.Cells(1).RowIndex
                    End If
                    
                Next
               If A = 1 Then Exit Do
            WordTable.Split (A)
          A = 1
        Loop

Any help or guidance would be greatly appreciated.

Thanks
Thom

macropod · #6 03-09-2022, 04:33 PM

In post #2, I've made some minor code improvements to the output table's appearance (e.g. made the header row repeat on new pages & reduced excessive row heights).

It would have been helpful had you specified your full requirements in your original thread. A significant code revision would be required to achieve the splitting. Amongst other things, one supposes you'd want each new table to have its own header, but you haven't said anything about that.

Threads merged.

Guessed · #7 03-09-2022, 04:58 PM

Try this code

Code:

Sub TableSplitter()
  Dim aTbl As Table, i As Integer, sVal As String, sValPrev As String
  
  Set aTbl = Selection.Tables(1)
  For i = aTbl.Rows.Count To 3 Step -1
    On Error Resume Next
      sVal = Split(aTbl.Rows(i).Cells(1).Range.Text, ".")(1)
      sValPrev = Split(aTbl.Rows(i - 1).Cells(1).Range.Text, ".")(1)
    On Error GoTo 0
    Debug.Print "Row:" & i, sVal, sValPrev
    If sVal = sValPrev Then
      GoTo Jumper
    Else
      aTbl.Split i
    End If
Jumper:
  Next i
End Sub

macropod · #8 03-09-2022, 07:42 PM

Here is the modified code to accommodate your updated requirements. Note the changes in bold:

Code:

Sub ExcelRangeToWord()
'Initialize
Application.ScreenUpdating = False
Dim WdApp As Word.Application, WdDoc As Word.Document, WdTbl As Word.Table, WdRng As Word.Range, i As Long, j As Long, k As Long
Const SecNum As String = "6."

'Instantiate Word
Set WdApp = CreateObject("Word.Application")

With WdApp
  'Make MS Word Visible
  .Visible = True
  'Create a New Document
  Set WdDoc = .Documents.Add
  'Copy Excel Table Range
  ThisWorkbook.Worksheets("InspectionPivot").PivotTables("InspectionPivot").TableRange2.Copy
  With WdDoc
    'Paste Table into MS Word
    .Paragraphs(1).Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
    Set WdTbl = .Tables(1)
    'Set Table column widths
    With WdTbl
      .Rows(1).HeadingFormat = True
      .Rows(1).Range.ParagraphFormat.KeepTogether = True
      .Rows(1).Range.ParagraphFormat.KeepWithNext = True
      .Rows.HeightRule = wdRowHeightAuto
      .Columns(1).Width = WdApp.CentimetersToPoints(0.5)
      .Columns(2).Width = WdApp.CentimetersToPoints(3)
      .Columns(3).Width = WdApp.CentimetersToPoints(11.5)
      .Columns(4).Width = WdApp.CentimetersToPoints(1)
      j = Split(.Rows(.Rows.Count).Cells(1).Range, ".")(0)
      
      For i = .Rows.Count To 2 Step -1
        With .Rows(i)
          If Len(.Range.Text) <= .Cells.Count * 3 + 2 Then
            'delete empty rows
            .Delete
          Else
            k = Split(.Cells(1).Range, ".")(0)
            'Insert report ref section # before item #
            .Cells(1).Range.InsertBefore (SecNum)
            'Split the table at a numbering change
            If j <> k And i > 2 Then
              j = k
              With WdTbl
                .Split .Rows(i + 1)
                .Range.Characters.Last.Next.FormattedText = .Rows(1).Range.FormattedText
                .Split .Rows(i + 1)
              End With
            End If
          End If
        End With
      Next i
    End With
  End With

  With WdRng
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = "Recommended Action"
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
    End With
    Do While .Find.Execute
      If .InRange(WdRng) = True Then
        .End = .Cells(1).Range.End - 1
        .Style = wdStyleEmphasis
      Else
        Exit Do
      End If
      .Collapse wdCollapseEnd
    Loop
  End With
  'Display Document
  .Activate
End With
'Clean Up
Set WdTbl = Nothing: Set WdDoc = Nothing: Set WdApp = Nothing
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Thom.Simmo · #9 03-15-2022, 08:39 AM

Guessed, thankyou for the section of code, it works perfectly when appended to the original section of code I had put together.

Macropod, thanks again for you help. My apologies if my approach is frustrating. Unfortunately I don't know enough about what I am doing to tackle everything in one go so had resigned myself to adding in functionality in sections as I learn what I am doing.

there is an issue at this line when I run the code

Code:

ThisWorkbook.Worksheets("InspectionPivot").PivotTables("InspectionPivot").TableRange2.Copy

I had set a variable for the excel table but I see you have not done that, could you explain how this is supposed to work?

Thanks
Thom

macropod · #10 03-15-2022, 02:05 PM

Quote:

Originally Posted by Thom.Simmo

there is an issue at this line when I run the code

Code:

ThisWorkbook.Worksheets("InspectionPivot").PivotTables("InspectionPivot").TableRange2.Copy

I had set a variable for the excel table but I see you have not done that, could you explain how this is supposed to work?

I haven't worked with pivot tables before. Regardless, there is no need to have:

Code:

Dim tbl As PivotTable
...
Set tbl = ThisWorkbook.Worksheets("InspectionPivot").PivotTables("InspectionPivot")
...
tbl.TableRange2.Copy

when all you do is define the pivot table then copy it.

Guessed · #11 03-15-2022, 05:28 PM

Perhaps the issue is the name of the worksheet or pivot table isn't correct. Certainly that is two things that might cause that code line to fail. You can adjust the code to something less specific by changing the code to

Code:

ActiveSheet.PivotTables(1).Copy

which only needs the active worksheet to have at least one pivot table in it to work.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
How to change the font color of specific text within a Word table cell	epid011	Word Tables	2	05-15-2017 05:21 PM
How do I add selection of multi line content control list to specific table cell	Dudlee	Word VBA	1	09-20-2016 04:58 PM
VBA Table – Search All Tables - Find & Replace Text in Table Cell With Specific Background Color	jc491	Word VBA	8	09-30-2015 06:10 AM
Creating a plain text content control for every instance of a word or phrase	RobsterCraw	Word VBA	16	11-20-2012 03:25 PM
Word VBA: Cannot Edit Range (Delete characters except the first in a table cell)	tinfanide	Word VBA	3	04-27-2012 09:48 AM