![]() |
|
![]() |
|
Thread Tools | Display Modes |
|
#1
|
||||
|
||||
![]() 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] |
#2
|
|||
|
|||
![]()
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 Cheers Thom |
![]() |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
![]() |
epid011 | Word Tables | 2 | 05-15-2017 05:21 PM |
![]() |
Dudlee | Word VBA | 1 | 09-20-2016 04:58 PM |
![]() |
jc491 | Word VBA | 8 | 09-30-2015 06:10 AM |
![]() |
RobsterCraw | Word VBA | 16 | 11-20-2012 03:25 PM |
![]() |
tinfanide | Word VBA | 3 | 04-27-2012 09:48 AM |