Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 03-06-2022, 04:14 AM
macropod's Avatar
macropod macropod is offline Define range within word table between specific text instance and end of cell content Windows 10 Define range within word table between specific text instance and end of cell content Office 2016
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 22,467
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default


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
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #2  
Old 03-08-2022, 08:30 AM
Thom.Simmo Thom.Simmo is offline Define range within word table between specific text instance and end of cell content Windows 10 Define range within word table between specific text instance and end of cell content Office 2019
Novice
Define range within word table between specific text instance and end of cell content
 
Join Date: Mar 2022
Posts: 5
Thom.Simmo is on a distinguished road
Default

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
Reply With Quote
Reply



Similar Threads
Thread Thread Starter Forum Replies Last Post
Define range within word table between specific text instance and end of cell content How to change the font color of specific text within a Word table cell epid011 Word Tables 2 05-15-2017 05:21 PM
Define range within word table between specific text instance and end of cell content 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
Define range within word table between specific text instance and end of cell content 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
Define range within word table between specific text instance and end of cell content Creating a plain text content control for every instance of a word or phrase RobsterCraw Word VBA 16 11-20-2012 03:25 PM
Define range within word table between specific text instance and end of cell content Word VBA: Cannot Edit Range (Delete characters except the first in a table cell) tinfanide Word VBA 3 04-27-2012 09:48 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 11:08 PM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2025, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2025 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft