How to duplicate paragraphs & format them

[effimera]

Hello there,

I am wondering if someone could help me with a similar task of duplicating paragraphs (except in tables, not in textboxes either) by using VBA.

I tried to record a macro that duplicates source paragraphs underneath and italicizes the duplicated ones at the same time, but it doesn't work properly.
I recorded it with 3 paragraphs, but this is the problem -- if I run the macro on larger text (i.e. with more than three paragraphs), it does so on the first three only, and the rest remains unduplicated.


So, does anybody know how to refine it in order to duplicate and italicize an unlimited number of paragraphs. And please with no locking, as I would often need to select and hide or format them for CAT translation.

Here it is:

  Sub DuplicateAndItalicizeParagraph()
  '
  ' DuplicateAndItalicizeParagraph Makro
  '
  '
      Selection.HomeKey Unit:=wdStory
      Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
      Selection.Copy
      Selection.MoveRight Unit:=wdCharacter, Count:=1
      Selection.TypeParagraph
      Selection.MoveUp Unit:=wdLine, Count:=1
      Selection.PasteAndFormat (wdFormatOriginalFormatting)
      Selection.MoveLeft Unit:=wdCharacter, Count:=1
      Selection.MoveUp Unit:=wdParagraph, Count:=1, Extend:=wdExtend
      Selection.Font.Italic = wdToggle
      Selection.MoveRight Unit:=wdCharacter, Count:=3
      Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
      Selection.Copy
      Selection.MoveRight Unit:=wdCharacter, Count:=1
      Selection.TypeParagraph
      Selection.MoveUp Unit:=wdLine, Count:=1
      Selection.PasteAndFormat (wdFormatOriginalFormatting)
      Selection.MoveLeft Unit:=wdCharacter, Count:=1
      Selection.MoveUp Unit:=wdParagraph, Count:=1, Extend:=wdExtend
      Selection.Font.Italic = wdToggle
      Selection.MoveRight Unit:=wdCharacter, Count:=3
      Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
      Selection.Copy
      Selection.MoveRight Unit:=wdCharacter, Count:=1
      Selection.TypeParagraph
      Selection.PasteAndFormat (wdFormatOriginalFormatting)
      Selection.MoveLeft Unit:=wdCharacter, Count:=1
      Selection.MoveUp Unit:=wdParagraph, Count:=1, Extend:=wdExtend
      Selection.Font.Italic = wdToggle
      Selection.MoveRight Unit:=wdCharacter, Count:=1
  End Sub

Thank you in advance.

[gmayor]

Without the document to test, the following should work

Sub Macro1()
Dim oRng As Range
Dim oPara As Range, oNewPara As Range
Dim i As Long
    Set oRng = Selection.Range
    If oRng.End = ActiveDocument.Range.End Then
        oRng.InsertParagraphAfter
    End If
    For i = oRng.Paragraphs.Count To 1 Step -1
        Set oPara = oRng.Paragraphs(i).Range
        Set oNewPara = oPara.Duplicate
        oNewPara.Collapse 0
        oNewPara.FormattedText = oPara.FormattedText
        oNewPara.Font.Italic = True
    Next i
lbl_Exit:
    Set oRng = Nothing
    Set oPara = Nothing
    Set oNewPara = Nothing
    Exit Sub
End Sub

[effimera]

Originally Posted by gmayor

Without the document to test, the following should work

Sub Macro1()
Dim oRng As Range
Dim oPara As Range, oNewPara As Range
Dim i As Long
    Set oRng = Selection.Range
    If oRng.End = ActiveDocument.Range.End Then
        oRng.InsertParagraphAfter
    End If
    For i = oRng.Paragraphs.Count To 1 Step -1
        Set oPara = oRng.Paragraphs(i).Range
        Set oNewPara = oPara.Duplicate
        oNewPara.Collapse 0
        oNewPara.FormattedText = oPara.FormattedText
        oNewPara.Font.Italic = True
    Next i
lbl_Exit:
    Set oRng = Nothing
    Set oPara = Nothing
    Set oNewPara = Nothing
    Exit Sub
End Sub

Thank you, gmayor!
It works perfectly - much obliged