duplicate specific text and underline it

[Ethen5155]

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


24294


After


24295

i have attached a sample file for such a case

Thanks in advance for any hint or tips

Cheers


Cross Posted link: Here (https://www.excelforum.com/word-programming-vba-macros/1277672-duplicate-specific-text-and-underline-it.html#post5128777)

[gmayor]

I guess something like


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

[Ethen5155]

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

24298



your support is always appreciated

[gmaxey]

You might try this adaptation of Graham's original 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

[Ethen5155]

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

[gmayor]

Add the line

DoEvents
immediately before the line

Loop
This will prevent the bottleneck

[Ethen5155]

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

[Ethen5155]

i think there is issue about the table?!!

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

[gmayor]

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

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

[Ethen5155]

Hi Graham ,

you are my savior :) :)

it works like magic now, your support is highly appreciated

Cheers