Word VBA copy text formatted text in a certain font to a file and other formatting in other file-CodePudding

From a comparison docx file I need to extract into two word files the text formatted as strikethrough in one docx file and the text formatted as double underline in another docx file to be able to perform the wordcount of newly inserted and deleted text separately. To do this, I wrote this macro, that actually activates the correct files, but only copies and pastes the formatting resulting from the first search.

    Sub WSC_extraction_for_wordcount()
    'This macro extracts double underlined text to the file "target_ins"
    'This macro extracts strikethrough text to the file "target_del"

    Application.ScreenUpdating = False
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting

    'STRIKETHROUGH processing
    Do
    With Selection.Find.Font
    .StrikeThrough = True 'Then
    Selection.Find.Execute FindText:="", Forward:=True, Format:=True
    Selection.Cut
    Windows("target_del.docx").Activate
    Selection.PasteAndFormat (wdPasteDefault)
    Selection.TypeParagraph
    Windows("source.docx").Activate
    End With

    'DOUBLE UNDERLINE processing
    With Selection.Find.Font
    .Underline = wdUnderlineDouble = True 'Then
    Selection.Find.Execute FindText:="", Forward:=True, Wrap:=wdFindContinue, Format:=True
    Selection.Cut
    Windows("target_ins.docx").Activate
    Selection.PasteAndFormat (wdPasteDefault)
    Selection.TypeParagraph
    Windows("source.docx").Activate
    End With
    Loop
    End Sub

I would be grateful if someone could help me in transforming the options into something like: if the next sentence you encounter is formatted as strikethrough, copy it to file target_del, if the next sentence you encounter is formatted as double underlined, copy it to the file target_ins.

Thank you in advance!

CodePudding user response：

The code below avoids the use of the Selection object. It also assumes that the documents the text is to be moved to are already open.

Sub WSC_extraction_for_wordcount()
    'This macro extracts double underlined text to the file "target_ins"
    'This macro extracts strikethrough text to the file "target_del"

    Application.ScreenUpdating = False
    Dim source As Document: Set source = ActiveDocument
    Dim targetDel As Document: Set targetDel = Documents("target_del.docx")
    Dim targetIns As Document: Set targetIns = Documents("target_ins.docx")

    'STRIKETHROUGH processing
    With source.Content
        With .Find
            .ClearFormatting
            .Text = ""
            .Replacement.ClearFormatting
            .Text = ""
            .Forward = True
            .Format = True
            .Wrap = wdFindStop
            .Font.StrikeThrough = True
        End With
        Do While .Find.Execute
            targetDel.Characters.Last.FormattedText = .FormattedText
            targetDel.Characters.Last.InsertParagraphAfter
            .Delete
        Loop
    End With
        
    'DOUBLE UNDERLINE processing
    With source.Content
        With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Format = True
            .Font.Underline = wdUnderlineDouble
        End With
        Do While .Find.Execute
            targetIns.Characters.Last.FormattedText = .FormattedText
            targetIns.Characters.Last.InsertParagraphAfter
            .Delete
        Loop
    End With
End Sub

CodePudding user response：

Without the overhead of creating new documents:

Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, j As Long
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Font.Underline = wdUnderlineDouble
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
  End With
  Do While .Find.Execute
    i = i   .ComputeStatistics(wdStatisticWords)
    If .Information(wdWithInTable) = True Then
      If .End = .Cells(1).Range.End - 1 Then
        .End = .Cells(1).Range.End
        .Collapse wdCollapseEnd
        If .Information(wdAtEndOfRowMarker) = True Then
          .End = .End   1
        End If
      End If
    End If
    If .End = ActiveDocument.Range.End Then Exit Do
    .Collapse wdCollapseEnd
  Loop
End With
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Font.StrikeThrough = True
    .Forward = True
    .Wrap = wdFindStop
  End With
  Do While .Find.Execute
    j = j   .ComputeStatistics(wdStatisticWords)
    If .Information(wdWithInTable) = True Then
      If .End = .Cells(1).Range.End - 1 Then
        .End = .Cells(1).Range.End
        .Collapse wdCollapseEnd
        If .Information(wdAtEndOfRowMarker) = True Then
          .End = .End   1
        End If
      End If
    End If
    If .End = ActiveDocument.Range.End Then Exit Do
    .Collapse wdCollapseEnd
  Loop
End With
Application.ScreenUpdating = True
MsgBox i & " words added." & vbCr & j & " words deleted."
End Sub