|
|
Thread Tools | Display Modes |
#1
|
|||
|
|||
Define range within word table between specific text instance and end of cell content
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 |
#2
|
||||
|
||||
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] |
#3
|
|||
|
|||
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 |
#4
|
|||
|
|||
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 |
#5
|
|||
|
|||
Split table at row based on characters within cell
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 Thanks Thom |
#6
|
||||
|
||||
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.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#7
|
||||
|
||||
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
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#8
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#9
|
|||
|
|||
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 Thanks Thom |
#10
|
||||
|
||||
Quote:
Code:
Dim tbl As PivotTable ... Set tbl = ThisWorkbook.Worksheets("InspectionPivot").PivotTables("InspectionPivot") ... tbl.TableRange2.Copy
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#11
|
||||
|
||||
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
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
|
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 |