duplicate specific text and underline it

Hello All,


i have a huge number of files need to be translated with specific instructions


the most complicated case which i face is to duplicate all turquoise highlighted text and make the duplicated one's first character to be underlined


and the original one to be hidden as shown below


Before


Attachment 24294


After


Attachment 24295

i have attached a sample file for such a case

Thanks in advance for any hint or tips

Cheers


Cross Posted link: Here

I guess something like

Code:

---

Sub Macro1()'Graham Mayor - https://www.gmayor.com - Last updated - 29 May 2019
Dim oRng As Range
Dim i As Integer
    Set oRng = ActiveDocument.Range
    With oRng.Find
        .Highlight = True
        Do While .Execute
            oRng.Font.Underline = wdUnderlineNone
            oRng.NoProofing = True
            i = Len(oRng)
            oRng.InsertAfter oRng.Text
            oRng.MoveEnd Count:=i
            oRng.Characters(i + 1).Underline = wdUnderlineSingle
            For i = i To 1 Step -1
                oRng.Characters(i).Font.Hidden = True
            Next i
            oRng.Collapse 0
        Loop
    End With
lbl_Exit:
    Set oRng = Nothing
    Exit Sub
End Sub

---

should work

Hello Graham,

really i don't have enough words to thank you. you save my day

just one more thing to help if possible, as you see below it is supposed to be a space here

Attachment 24298



your support is always appreciated

You might try this adaptation of Graham's original code.

Code:

---

Sub Macro1()
Dim oRng As Range
Dim oRng2 As Range
Dim i As Long

  Set oRng = ActiveDocument.Range
  With oRng.Find
    .Highlight = True
    Do While .Execute
      oRng.Font.Underline = wdUnderlineNone
      oRng.NoProofing = True
      i = Len(oRng)
      Set oRng2 = oRng.Duplicate
      oRng2.InsertAfter " " & oRng.Text
      oRng2.Characters(i + 2).Underline = wdUnderlineSingle
      oRng.Font.Hidden = True
      oRng.Start = oRng2.End
      oRng.End = ActiveDocument.Range.End
    Loop
  End With
lbl_Exit:
  Set oRng = Nothing
  Exit Sub
End Sub

---

Hi Greg,

Your code works great but if i used it on more than one page it crashes!!

i think this is because the huge number of terms that need to be duplicated, i tried it on a file contains about 1000 terms

or is it about the the (Loop) in the code?!

Cheers

Add the line

Code:

---

DoEvents

---

immediately before the line

Code:

---

Loop

---

This will prevent the bottleneck

Hi Graham,

i'm really appreciate your support but unfortunately it still crashing !!

i have attached a sample file from one page only that failed to run the code on

i think there is issue about the table?!!

when i convert the table to text or delete the tables it works very well

Use the following variation of my original code which I think does what you now want, and doesn't crash in your table.

Code:

---

Sub Macro1()
'Graham Mayor - https://www.gmayor.com - Last updated - 31 May 2019
Dim oRng As Range
Dim i As Integer
    Set oRng = ActiveDocument.Range
    With oRng.Find
        .Highlight = True
        Do While .Execute
            oRng.Font.Underline = wdUnderlineNone
            oRng.NoProofing = True
            i = Len(oRng)
            oRng.InsertAfter Chr(32) & oRng.Text
            oRng.MoveEnd Count:=i + 1
            oRng.Characters(i + 2).Underline = wdUnderlineSingle
            For i = i To 1 Step -1
                oRng.Characters(i).Font.Hidden = True
            Next i
            oRng.Collapse 0
            DoEvents
        Loop
    End With
lbl_Exit:
    Set oRng = Nothing
    Exit Sub
End Sub

---

Hi Graham ,

you are my savior :) :)

it works like magic now, your support is highly appreciated

Cheers