Macro to reformat text not working - help

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.

Code:

---

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!

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.

Quote:

---

Originally Posted by 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.

---

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.



Attachment 31040

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

Code:

---

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

---

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).

Code:

---

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

---

This seems to work:

Code:

---

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

---

Quote:

---

Originally Posted by gmaxey

This seems to work:

Code:

---

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?

Quote:

---

Originally Posted by gmaxey

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

Code:

---

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:

Code:

---

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?

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.

Code:

---

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

---

Quote:

---

Originally Posted by 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.

---

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

Quote:

---

Originally Posted by gmaxey

Code:

---

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. :)