Macro to reformat text not working - help

[Restricted]

Hi all, I have some text in a table in Word, which I want to get from this format:

Domain1Fruits and Vegetables of the Day
Sub-domain1A5Types of Fruits and Vegetables
Task Statement1Eating fruits that determine whether you will be healthier.

To this format:

Domain: 1 - Fruits and Vegetables of the Day
Sub-domain: 1A5 - Types of Fruits and Vegetables
Task Statement: 1 - Eating fruits that determine whether you will be healthier.

Syntax is effectively:
Domain: # - DomainDesc
Sub-domain: #XY - SubdomainDesc
Task Statement: F - TaskStatementDesc

Where '#' is going to be a Single-digit Number
Where 'X' is going to be a Single Letter
Where 'Y' is going to be an Integer/Number
Where 'F" is going to be an Integer/Number
Where 'DomainDesc' is going to be a sentence describing the Domain
Where 'SubdomainDesc' is going to be a sentence describing the Sub-domain
Where 'TaskStatementDesc' is going to be a sentence describing the Task Statement



Effectively I have a 4x900 table in Microsoft Word, and the example text above is all in one column (i.e. so there's lots of similar examples in the same format above), but it's not formatted nicely (as per above), and I need it to look like the 'To' format above. I don't want to have to do this formatting manually for all 900 rows in the column so thought VBA would be great for this.

I have tried something like this based on collating various snippets of code online and modifying it to my usage, but it is simply deleting my selected text (it thinks 'elements' is empty) and I am not sure what's going wrong or if there's an easier way to do this.



Sub FormatTextBeforeToAfter()
Dim selectedRange As Range
Dim formattedText As String
Dim lines() As String
Dim resultText As String
Dim i As Integer

' Check if text is selected
If Not Selection.Text = "" Then
' Get the selected range
Set selectedRange = Selection.Range
formattedText = selectedRange.Text

' Split the formattedText into lines
lines = Split(formattedText, vbCrLf)

' Initialize the result text
resultText = ""

' Loop through each line and format it
For i = LBound(lines) To UBound(lines)
' Check if the line is not empty
If Trim(lines(i)) <> "" Then
Dim elements() As String
elements = Split(lines(i), " - ")

If UBound(elements) >= 1 Then
' Extract parts
Dim domainPart As String
Dim subdomainPart As String
Dim taskStatementPart As String

domainPart = "Domain: " & elements(1) & " - " & elements(0)

If UBound(elements) >= 2 Then
subdomainPart = "Sub-domain: " & Mid(elements(2), 1, 2) & " - " & Mid(elements(2), 3) ' Adjusted to capture the numeric part.
End If

If UBound(elements) >= 3 Then
taskStatementPart = "Task Statement: " & Mid(elements(3), 1, 2) & " - " & Mid(elements(3), 3) ' Adjusted to capture the numeric part.
End If

' Add the formatted parts to the result
resultText = resultText & domainPart & vbCrLf & subdomainPart & vbCrLf & taskStatementPart & vbCrLf
End If
End If
Next i

' Replace the selected text with the formatted result text
selectedRange.Text = resultText
Else
MsgBox "No text is selected. Please select the text you want to format."
End If
End Sub


Any help would be greatly appreciated thank you!

[gmayor]

Can you post a document (or a link to a document) sample of the original document (at least three rows) and a sample document of how you want it to appear.

[Restricted]

Can you post a document (or a link to a document) sample of the original document (at least three rows) and a sample document of how you want it to appear.

Of course - please see attached. Refer to 'Sample Original' and 'Sample to appear like' (page 2) respectively.

Please also note if it is possible, if the code can also change any numbered bullet points (e.g. 1., 2., 3., 4.) into lettered bullet points (e.g. A., B., C., D.). I tried to do this but Word crashed - also demonstrated in 'Sample Original' and 'Sample to appear like' (page 2) respectively.



31040

[gmaxey]

Not sure when Graham will be back. This is not the cleanest solution, but I didn't have much time:


Sub ScratchMacro()
'A basic Word Macro coded by Gregory K. Maxey
Dim oTbl As Table
Dim lngRow As Long
Dim oRng As Range
Set oTbl = Selection.Tables(1)
For lngRow = 2 To oTbl.Rows.Count
Set oRng = oTbl.Rows(lngRow).Cells(3).Range
With oRng.Find
.Text = "Domain"
If .Execute Then
oRng.InsertAfter ": "
oRng.Collapse wdCollapseEnd
oRng.Move wdCharacter, 1
oRng.InsertAfter " "
oRng.Collapse wdCollapseEnd
oRng.InsertSymbol Font:="Times New Roman", CharacterNumber:=8211, Unicode:=True
oRng.Collapse wdCollapseEnd
oRng.Move wdCharacter, 1
oRng.InsertAfter " "
oRng.Paragraphs(1).SpaceAfter = 12
End If
End With
Set oRng = oTbl.Rows(lngRow).Cells(3).Range
With oRng.Find
.Text = "Sub-domain"
If .Execute Then
oRng.InsertAfter ": "
oRng.Collapse wdCollapseEnd
oRng.Move wdCharacter, 3
oRng.InsertAfter " "
oRng.Collapse wdCollapseEnd
oRng.InsertSymbol Font:="Times New Roman", CharacterNumber:=8211, Unicode:=True
oRng.Collapse wdCollapseEnd
oRng.Move wdCharacter, 1
oRng.InsertAfter " "
oRng.Paragraphs(1).SpaceAfter = 12
End If
End With
Set oRng = oTbl.Rows(lngRow).Cells(3).Range
With oRng.Find
.Text = "Task Statement"
If .Execute Then
oRng.InsertAfter ": "
oRng.Collapse wdCollapseEnd
oRng.Move wdCharacter, 1
oRng.InsertAfter " "
oRng.Collapse wdCollapseEnd
oRng.InsertSymbol Font:="Times New Roman", CharacterNumber:=8211, Unicode:=True
oRng.Collapse wdCollapseEnd
oRng.Move wdCharacter, 1
oRng.InsertAfter " "
End If
End With
Next
lbl_Exit:
Exit Sub
End Sub

[Restricted]

Thanks Greg - that worked.

How can we also modify the code (or a new, separate code/function) to change any numbered bullet points (e.g. 1., 2., 3., 4.) into lettered bullet points (e.g. A., B., C., D.). Example was demonstrated in 'Sample Original' and 'Sample to appear like' (page 2) respectively in attachment above.

I have tried something like this, but it does not work well - it makes everything (including non-bulleted text) bulleted, and in some cases, 'restarts' the numbered list (so 'A.' appears 4 times, instead of A, B, C, D in sequence).


Sub ConvertListsInTableToNumbered()
Dim tbl As Table
Dim cell As Cell
Dim para As Paragraph

' Define the table we want to process
Set tbl = ActiveDocument.Tables(1) ' Change the table index as needed

' Loop through each cell in the table
For Each cell In tbl.Range.Cells
' Loop through each paragraph in the cell
For Each para In cell.Range.Paragraphs
' Check if the paragraph has a numbered or bulleted list format
If para.Range.ListFormat.ListType <> wdListNoNumbering Then
' Convert the list to a numbered list
para.Range.ListFormat.ApplyListTemplate ListTemplate:= _
ListGalleries(wdNumberGallery).ListTemplates(1), _
ContinuePreviousList:=False, ApplyTo:=wdListApplyToWholeList, _
DefaultListBehavior:=wdWord10ListBehavior
End If
Next para
Next cell
End Sub

[gmaxey]

This seems to work:


Sub ConvertListsInTableToNumbered()
Dim tbl As Table
Dim cell As cell
Dim para As Paragraph
'Define the table we want to process
Set tbl = ActiveDocument.Tables(1) ' Change the table index as needed
'Loop through each cell in the table
For Each cell In tbl.Range.Cells
'Loop through each paragraph in the cell
For Each para In cell.Range.Paragraphs
para.Range.Select
'Check if the paragraph has a numbered or bulleted list format
If para.Range.ListFormat.ListType <> wdListNoNumbering Then
'Convert the list to a numbered list
para.Range.ListFormat.ApplyListTemplate ListTemplate:= _
ListGalleries(wdNumberGallery).ListTemplates(2), _
ContinuePreviousList:=False, ApplyTo:=wdListApplyToWholeList, _
DefaultListBehavior:=wdWord10ListBehavior
Exit For
End If
Next para
Next cell
End Sub

[Restricted]

This seems to work:


Sub ConvertListsInTableToNumbered()
Dim tbl As Table
Dim cell As cell
Dim para As Paragraph
'Define the table we want to process
Set tbl = ActiveDocument.Tables(1) ' Change the table index as needed
'Loop through each cell in the table
For Each cell In tbl.Range.Cells
'Loop through each paragraph in the cell
For Each para In cell.Range.Paragraphs
para.Range.Select
'Check if the paragraph has a numbered or bulleted list format
If para.Range.ListFormat.ListType <> wdListNoNumbering Then
'Convert the list to a numbered list
para.Range.ListFormat.ApplyListTemplate ListTemplate:= _
ListGalleries(wdNumberGallery).ListTemplates(2), _
ContinuePreviousList:=False, ApplyTo:=wdListApplyToWholeList, _
DefaultListBehavior:=wdWord10ListBehavior
Exit For
End If
Next para
Next cell
End Sub


Thanks greg, that works - I noticed the only change you had to make was to change the parameter in ListTemplates from 1 to 2 - what does that do so that it worked? Was hard to find documentation around this. Is '2' just the 'correct' collection of the bullet points list/styles applicable for me?

[Restricted]

Not sure when Graham will be back. This is not the cleanest solution, but I didn't have much time:


Sub ScratchMacro()
'A basic Word Macro coded by Gregory K. Maxey
Dim oTbl As Table
Dim lngRow As Long
Dim oRng As Range
Set oTbl = Selection.Tables(1)
For lngRow = 2 To oTbl.Rows.Count
Set oRng = oTbl.Rows(lngRow).Cells(3).Range
With oRng.Find
.Text = "Domain"
If .Execute Then
oRng.InsertAfter ": "
oRng.Collapse wdCollapseEnd
oRng.Move wdCharacter, 1
oRng.InsertAfter " "
oRng.Collapse wdCollapseEnd
oRng.InsertSymbol Font:="Times New Roman", CharacterNumber:=8211, Unicode:=True
oRng.Collapse wdCollapseEnd
oRng.Move wdCharacter, 1
oRng.InsertAfter " "
oRng.Paragraphs(1).SpaceAfter = 12
End If
End With
Set oRng = oTbl.Rows(lngRow).Cells(3).Range
With oRng.Find
.Text = "Sub-domain"
If .Execute Then
oRng.InsertAfter ": "
oRng.Collapse wdCollapseEnd
oRng.Move wdCharacter, 3
oRng.InsertAfter " "
oRng.Collapse wdCollapseEnd
oRng.InsertSymbol Font:="Times New Roman", CharacterNumber:=8211, Unicode:=True
oRng.Collapse wdCollapseEnd
oRng.Move wdCharacter, 1
oRng.InsertAfter " "
oRng.Paragraphs(1).SpaceAfter = 12
End If
End With
Set oRng = oTbl.Rows(lngRow).Cells(3).Range
With oRng.Find
.Text = "Task Statement"
If .Execute Then
oRng.InsertAfter ": "
oRng.Collapse wdCollapseEnd
oRng.Move wdCharacter, 1
oRng.InsertAfter " "
oRng.Collapse wdCollapseEnd
oRng.InsertSymbol Font:="Times New Roman", CharacterNumber:=8211, Unicode:=True
oRng.Collapse wdCollapseEnd
oRng.Move wdCharacter, 1
oRng.InsertAfter " "
End If
End With
Next
lbl_Exit:
Exit Sub
End Sub


Hi Greg how do we update the code so that it accommodates for where the 'Task Statement' is followed by more than 1 digit? e.g. 2 digits?

e.g. Task Statement5Bananas and muscle health, correctly turns into: Task Statement: 5 – Bananas and muscle health
However when there are 2 digits involved (e.g. '45' instead of '5'):
Task Statement45Bananas and muscle health, turns into: Task Statement: 4 – 5Bananas and muscle health
whereas it should be: Task Statement: 45 – Bananas and muscle health


I have tried to do it via ReGex by modifying your code, but the code isn't functioning properly - although it works to accommodate the 2 digits, it is instead replacing everything with only the "Task Statement" modifications, and not the "Domain" and "Sub-domain" modifications:



Sub ScratchMacro()
'A basic Word Macro coded by Gregory K. Maxey
Dim oTbl As Table
Dim lngRow As Long
Dim oRng As Range
Dim regEx As Object
Dim match As Object

' Create a regular expression object
Set regEx = CreateObject("VBScript.RegExp")
regEx.Global = True
regEx.IgnoreCase = True
regEx.Pattern = "Task Statement(\d+)([^0-9]+)"

Set oTbl = Selection.Tables(1)
For lngRow = 2 To oTbl.Rows.Count
Set oRng = oTbl.Rows(lngRow).Cells(3).Range
With oRng.Find
.Text = "Domain"
If .Execute Then
oRng.InsertAfter ": "
oRng.Collapse wdCollapseEnd
oRng.Move wdCharacter, 1
oRng.InsertAfter " "
oRng.Collapse wdCollapseEnd
oRng.InsertSymbol Font:="Times New Roman", CharacterNumber:=8211, Unicode:=True
oRng.Collapse wdCollapseEnd
oRng.Move wdCharacter, 1
oRng.InsertAfter " "
oRng.Paragraphs(1).SpaceAfter = 12
End If
End With
Set oRng = oTbl.Rows(lngRow).Cells(3).Range
With oRng.Find
.Text = "Sub-domain"
If .Execute Then
oRng.InsertAfter ": "
oRng.Collapse wdCollapseEnd
oRng.Move wdCharacter, 3
oRng.InsertAfter " "
oRng.Collapse wdCollapseEnd
oRng.InsertSymbol Font:="Times New Roman", CharacterNumber:=8211, Unicode:=True
oRng.Collapse wdCollapseEnd
oRng.Move wdCharacter, 1
oRng.InsertAfter " "
oRng.Paragraphs(1).SpaceAfter = 12
End If
End With
Set oRng = oTbl.Rows(lngRow).Cells(3).Range
With oRng.Find
.Text = "Task Statement"
If regEx.Test(oRng.Text) Then
Set match = regEx.Execute(oRng.Text)(0)
oRng.Text = "Task Statement: " & match.SubMatches(0) & " – " & match.SubMatches(1)
oRng.Paragraphs(1).SpaceAfter = 12
End If
End With
Next
lbl_Exit:
Exit Sub
End Sub



However this was just my thinking/approach (which didn't work well) - if you have any other ways to achieve it?

[gmaxey]

I also exited the For Each loop. List Templates are very confusing. I recorded a macro applying the Lettered style list and .ListTemplates(2) is what came up.

[gmaxey]

Set oRng = oTbl.Rows(lngRow).Cells(3).Range
With oRng.Find
.Text = "Task Statement"
If .Execute Then
oRng.InsertAfter ": "
Do While IsNumeric(oRng.Characters.Last.Next)
oRng.MoveEnd wdCharacter, 1
Loop
oRng.InsertAfter " "
oRng.Collapse wdCollapseEnd
oRng.InsertSymbol Font:="Times New Roman", CharacterNumber:=8211, Unicode:=True
oRng.Collapse wdCollapseEnd
oRng.Move wdCharacter, 1
oRng.InsertAfter " "
End If
End With

[Restricted]

I also exited the For Each loop. List Templates are very confusing. I recorded a macro applying the Lettered style list and .ListTemplates(2) is what came up.

Oh that must have been why! And noted, thanks Greg.



Set oRng = oTbl.Rows(lngRow).Cells(3).Range
With oRng.Find
.Text = "Task Statement"
If .Execute Then
oRng.InsertAfter ": "
Do While IsNumeric(oRng.Characters.Last.Next)
oRng.MoveEnd wdCharacter, 1
Loop
oRng.InsertAfter " "
oRng.Collapse wdCollapseEnd
oRng.InsertSymbol Font:="Times New Roman", CharacterNumber:=8211, Unicode:=True
oRng.Collapse wdCollapseEnd
oRng.Move wdCharacter, 1
oRng.InsertAfter " "
End If
End With

Legend, cheers again Greg. :)