Consulting

Results 1 to 11 of 11

Thread: Macro to reformat text not working - help

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1

    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.


    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!
    Last edited by Restricted; 09-08-2023 at 09:44 PM.

  2. #2
    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.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    Quote Originally Posted by gmayor View Post
    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.



    Sample Document - Before and After.docx
    Attached Files Attached Files

  4. #4
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,383
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  5. #5
    Quote Originally Posted by gmaxey View Post
    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?
    Last edited by Restricted; 09-11-2023 at 09:16 PM.

  6. #6
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,383
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  7. #7
    Quote Originally Posted by gmaxey View Post
    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 View Post
    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.

  8. #8
    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
    Last edited by Restricted; 09-10-2023 at 11:22 PM. Reason: what I tried

  9. #9
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,383
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  10. #10
    Quote Originally Posted by gmaxey View Post
    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?
    Last edited by Restricted; 09-11-2023 at 09:19 PM.

  11. #11
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,383
    Location
    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.
    Greg

    Visit my website: http://gregmaxey.com

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •