#1
|
|||
|
|||
Need help with word macro to duplicate paragraphs in word document
I need a macro to duplicate paragraph (with same format and style) and insert it below the original paragraph. I have issue when the paragraph is in a table cell (it will not go to next paragraph in the cell) or when a paragraph is located before a table (paragraph will insert into the table). Thank you!
Code:
Sub CopyPara() Dim testRng, oRng, newRng As Range Dim beforeTable, EOD As Boolean 'end of cell char EOC = Chr(13) & Chr(7) EOD = False beforeTable = False 'move selection to begining of the doc Selection.HomeKey Unit:=wdStory Do Until Selection.End = ActiveDocument.Range.End If counter > 0 Then Selection.MoveDown Unit:=wdParagraph, Count:=1 Else Set oRng = Selection.Paragraphs(1).Range End If 'select the first para Selection.Paragraphs(1).Range.Select Set oRng = Selection.Paragraphs(1).Range Set testRng = Selection.Next(Unit:=wdParagraph, Count:=1) 'test if next para is in a table If Not testRng Is Nothing Then If testRng.Information(wdWithInTable) Then beforeTable = True End If 'if it is last para oof the doc, exit loop If oRng.End = ActiveDocument.Range.End Then EOD = True MsgBox ("EOC = " & EOD) Exit Do End If 'count the characters char_count = Len(Trim(Selection.Paragraphs(1).Range)) 'check if empty para If char_count > 2 Then If oRng.Text Like "*" & EOC Or EOD Or beforeTable Then 'check if selection reach end of cell EOCCopyPaste (oRng) 'Do the EOC copy and paste beforeTable = False Else NormalCopyPaste (oRng) 'Do the nomal copy and paste End If End If 'move selection to new paragraph Selection.Move Unit:=wdParagraph, Count:=1 Loop End Sub Function NormalCopyPaste(ByVal Rng As Range) Dim newRng As Range Set newRng = Rng.Duplicate 'move the selection to the front of new range newRng.Collapse Direction:=wdCollapseEnd newRng.FormattedText = Rng.FormattedText Rng.Font.Hidden = True newRng.Font.Color = wdColorBlue 'move selection to end of new range Selection.End = newRng.End End Function Function EOCCopyPaste(ByVal Rng As Range) Dim newRng As Range 'exclude the EOC character Rng.End = Rng.End - 1 'Debug.Print Rng.Text 'insert a para Rng.InsertParagraphAfter 'duplicate the range Set newRng = Rng.Duplicate 'move the selection to the front of new range newRng.Collapse Direction:=wdCollapseEnd 'paste the new range newRng.FormattedText = Rng.FormattedText 'change color newRng.Font.Color = wdColorGreen ' 'newRng.Next.Delete 'remove the para mark 'newRng.Text = Replace(newRng.Text, vbCr, "") 'set the old range to hidden Rng.Font.Hidden = True 'move the selection to the end of new range Selection.End = newRng.End End Function Last edited by baidu0021; 07-04-2022 at 02:58 AM. Reason: update to Sub CopyPara |
#2
|
||||
|
||||
Try this macro
Code:
Sub TranslationPrep() Dim iPar As Double, aRng As Range, aPar As Paragraph Dim iCount As Double, aRngAdd As Range, iExtra As Integer With ActiveDocument For iPar = .Paragraphs.Count To 1 Step -1 Set aPar = .Paragraphs(iPar) Set aRng = aPar.Range If Len(aRng) > 2 Then Set aRngAdd = .Range(aRng.Start, aRng.Start) iExtra = Len(aRng.Text) - Len(Split(aRng.Text, vbCr)(0)) If iExtra > 1 Then aRng.End = aRng.End - iExtra aRngAdd.FormattedText = aRng.FormattedText aRngAdd.InsertParagraphAfter Else aRngAdd.FormattedText = aRng.FormattedText End If aRngAdd.Font.Hidden = True With aRng.Paragraphs.Last.Range .Font.ColorIndex = wdBlue .ListFormat.RemoveNumbers NumberType:=wdNumberParagraph End With End If Next iPar End With End Sub
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#3
|
|||
|
|||
This works perfectly! Thank you.
|
#4
|
|||
|
|||
Hi Andrew,
I just found out there are issues: 1. the last character of a paragraph in a table cell was removed if the para does not end with paragraph mark. 2. When the last part of the the paragraph text is a hyperlink, the macro hit runtime error " Cannot edit Range" and debug stops at "aRngAdd.InsertParagraphAfter" please try the code on new test doc to replicate the issue. Thank you. |
#5
|
||||
|
||||
OK, this version doesn't have that issue but won't retain other formatting into the duplicate.
Code:
Sub TranslationPrep() Dim iPar As Double, aRng As Range, aPar As Paragraph Dim iCount As Double, aRngAdd As Range, iExtra As Integer Dim sPar As String With ActiveDocument For iPar = .Paragraphs.Count To 1 Step -1 Set aPar = .Paragraphs(iPar) Set aRng = aPar.Range If Len(Trim(aRng.Text)) > 2 Then Set aRngAdd = .Range(aRng.Start, aRng.Start) sPar = Trim(Split(aRng.Text, vbCr)(0)) aRngAdd.Text = sPar & vbCr aRngAdd.Font.Hidden = True With aRng.Paragraphs.Last.Range .Font.ColorIndex = wdBlue .ListFormat.RemoveNumbers NumberType:=wdNumberParagraph End With End If Next iPar End With End Sub
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
[Word VBA macro] How to open the website [languagetool.org] and check my Word document? | citroen | Word VBA | 0 | 10-25-2020 05:07 AM |
ms word document text translation using vba code | pk_00 | Word VBA | 1 | 03-02-2020 03:11 PM |
Macro to extract bookmarked data from Word document and insert into another Word Document | VStebler | Word VBA | 3 | 05-03-2018 05:02 PM |
Macro to transfer data from Word to another Word document with bookmark | Jovan Yong | Word VBA | 3 | 04-17-2018 04:27 AM |
Word Macro to publish document as pdf (Word 2010) | bville | Word VBA | 2 | 04-11-2013 03:30 PM |