Particular cut, paste and replace for red text

[mpeterson]

Dear All,

I'm working on a file that contains over 30000 multiple choice questions that are still under processing.

As per attached file 18528, "original text" shows how the text looks like in that file which includes 4 made-up examples:
1. Each question is a number of lines that vary from one question to another, in the example file the first question has four lines, and the third question has nine lines.
2. Each question is separated from the following question with an empty paragraph.
3. Each line has a part of its text formatted in red colour.
4. Each red part of the text varies in length.

As per "desired output" in the example file, what is required is as follows:
1. Cutting all red texts in all lines per question and replacing them with ten dots in each line.
2. Pasting them on one line under their question as listed items separated with %. In other words the pasted red text is to be formatted as a list and all carriage returns for the list items to be replaced with %.

I usually do this manually but for a handful number of questions, but for over 30000 questions I definitely do need some help. Can I get some expert assistance with this issue please?

Many thanks in advance.

[mana]

Plaese try this.


Option Explicit


Sub test()
Dim aryl As Object
Dim r As Range

Set aryl = CreateObject("System.Collections.ArrayList")

Set r = ActiveDocument.Content

With r.Find
.Font.Color = wdColorRed
Do While .Execute
aryl.Add r.Text
Loop
End With

Set r = ActiveDocument.Content

With r.Find
.Font.Color = wdColorRed
.Replacement.Font.Color = wdColorAutomatic
.Replacement.Text = ".........."
.Execute Replace:=wdReplaceAll
End With

MsgBox Join(aryl.toarray, "%")

End Sub

[Paul_Hossler]

Where / how does these lines come from?



%a. language and%b. second language%c. linguistic%d. general interest

[gmaxey]

Per your example:


Sub ScrathcMacro()
'A basic Word macro code by Greg Maxey and adapted from Mana's suggestion.
Dim oRng As Range, oRgSegment As Range
Dim arrList As Object
Dim lngIndex As Long
Dim strText As String
If Not Len(ActiveDocument.Range.Paragraphs.Last.Range) = 1 Then
ActiveDocument.Range.Paragraphs.Last.Range.InsertAfter vbCr
End If
Set oRng = ActiveDocument.Range
oRng.Collapse wdCollapseStart
Set arrList = CreateObject("System.Collections.ArrayList")
Do
Do
oRng.MoveEnd wdParagraph
Loop Until Len(oRng.Paragraphs.Last.Range) = 1
Set oRgSegment = oRng.Duplicate
With oRgSegment.Find
.Font.Color = wdColorRed
Do While .Execute
If Not oRgSegment.InRange(oRng) Then Exit Do
arrList.Add oRgSegment.Text
oRgSegment.Text = ".........."
oRgSegment.Font.Color = wdColorAutomatic
oRgSegment.Collapse wdCollapseEnd
Loop
End With
strText = vbNullString
For lngIndex = 0 To UBound(arrList.toarray)
strText = strText & "%" & fcnIntergerToLetter(lngIndex) & ". " & arrList(lngIndex)
Next
oRng.Paragraphs.Last.Range.Text = vbCr & strText & vbCr + vbCr
arrList.Clear
'oRng.Paragraphs.Last.Range.Text = Join(arrList.toarray, "%") & vbCr & vbCr
oRng.Collapse wdCollapseEnd
oRng.Move wdParagraph, 3 '2
Loop Until oRng.Paragraphs.Last.Range.End = ActiveDocument.Range.End
lbl_Exit:
Exit Sub
End Sub
Function fcnIntergerToLetter(lngCount As Long)
If lngCount = 0 Then
fcnIntergerToLetter = "a"
Else
If lngCount < 26 Then
fcnIntergerToLetter = LCase(Chr(lngCount + 1 + 64))
Else
fcnIntergerToLetter = "Error"
End If
End If
End Function

[mpeterson]

Hi Greg,

You did it again!! This is really incredible. Your code released a big burden off my head; it ran smoothly and did the job as perfectly as it could be done. Marvelous Greg .. really marvelous. You proved an asset to this world.
Always grateful to you for your input which I cannot compare with anybody's else.
Thank you very much Greg ...

[gmaxey]

Thanks for the kind words. Of course it is limited to 26 questions per group and in a long document may be sped up by

Sandwiching everything after the dim statements and before the lbl_Exit between:

Application.ScreenUpdating = False

Application.ScreenUpdating = True