![]() |
#1
|
|||
|
|||
![]()
I am trying to update the code below to insert the word 'means' at the beginning of each row in the second column if the word 'means' is not already present within column 2.
After the call in Test_ApplyDefinitionsStylesToTable has been called and run, I then want to remove the word 'means'. The reason behind this is that if text is not before an opening bracket that is not part of a sublevel, the Test_ApplyDefinitionsStylesToTable code removes the first word and bracket and inserts a numbering style, so my thinking is to prevent this from happening it would be best to insert a word first, run the code, then remove the word at the end of the code. Does anyone have any suggestions on how to do this? test doc for definitions table.docx Code:
Sub Test_TextToTables() Dim rRng As Range, rCell As Range 'Convert text to table Dim oBorder As Border Dim oTbl As Table Dim i As Integer Application.ScreenUpdating = False Set rRng = ActiveDocument.Range Set oTbl = rRng.ConvertToTable(Separator:=wdSeparateByTabs, NumColumns:=2, AutoFitBehavior:=wdAutoFitFixed) With oTbl .Style = "Table Grid" .ApplyStyleHeadingRows = True .ApplyStyleLastRow = False .ApplyStyleFirstColumn = True .ApplyStyleLastColumn = False .Columns.PreferredWidth = InchesToPoints(2.7) .Columns(2).PreferredWidth = InchesToPoints(3.63) For Each oBorder In .Borders oBorder.LineStyle = wdLineStyleNone Next oBorder For i = 1 To .Rows.count 'check each row Set rCell = .Cell(i, 1).Range 'set a range to the cells in column 1 rCell.Style = "DefBold" 'apply the style to the range Set rCell = .Cell(i, 2).Range 'set a range to the cells in column 2 rCell.Collapse 1 'collapse the range to its start rCell.MoveEndWhile Chr(32) 'move the end of the range to include any following spaces rCell.text = "" 'and empty the range For Each oTbl In ActiveDocument.Tables Set rRng = oTbl.Range rRng.End = rRng.End - 2 If rRng.Characters.Last = ";" Then rRng.Characters.Last = "." Next oTbl 'End If Next i End With 'Call DPU_TableLeadingSpaces Call DPU_ApplyDefinitionStylesToTable Application.ScreenUpdating = True Set rRng = Nothing Set oTbl = Nothing Set rCell = Nothing Set oBorder = Nothing End Sub Sub Test_ApplyDefinitionStylesToTable() 'Apply housestyle definition numbering to column 2 of table Application.ScreenUpdating = False Dim r As Long, i As Long, rCell As Range, oTbl As Table, rRng As Range With ActiveDocument.Tables(1) For r = 1 To .Rows.count With .Cell(r, 2).Range If .Characters.First <> "(" Then .Style = "Definition Level A" Else i = Asc(Split(Split(.text, "(")(1), ")")(0)) Select Case i Case 97 To 104, 106 To 117, 119, 121 To 122: .Style = "Definition Level 1" 'LowercaseLetter Case 105, 118, 120: .Style = "Definition Level 2" 'LowercaseRoman Case 65 To 90: .Style = "Definition Level 3" 'UppercaseLetter Case 48 To 57: .Style = "Definition Level 4" 'Arabic End Select .Collapse wdCollapseStart .MoveEndUntil " " .End = .End + 1 .Delete End If End With Next End With Application.ScreenUpdating = True End Sub |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
![]() |
kita299 | Word | 3 | 01-15-2023 05:06 PM |
![]() |
WJSwanepoel | Word VBA | 2 | 08-17-2022 05:11 AM |
Automatically put a text string at the beginning of a paragraph | jthomas666 | Word | 2 | 08-22-2019 12:27 PM |
![]() |
ballmoney | Word | 1 | 01-17-2010 02:19 AM |
Looping macros to add text to beginning and end of a paragraph | pachmarhi | Word VBA | 0 | 02-16-2009 06:57 AM |