Microsoft Office Forums - View Single Post - [Solved] Duplicate paragraphs except in tables

Guessed · 05-24-2021, 04:29 AM

We can't see what you are doing with hidden text. You might need to post a sample document to demonstrate what isn't happening correctly for you.

My interpretation of what you need for both macros is a variation on how Graham has done it. You could give this a try to see if it avoids the offset style issue you are having.

Code:

Sub TransPhile()
  Dim oSource As Document, oTarget As Document
  Dim oRng As Range, aTbl As Table, aRow As Row
  Dim oCC1 As ContentControl, oCC2 As ContentControl, i As Integer
  
  Set oSource = ActiveDocument
  oSource.Save
  If oSource.Path = "" Then GoTo lbl_Exit
  Set oTarget = Documents.Add(oSource.FullName)
  
  'Remove existing tables
  For i = oTarget.Tables.Count To 1 Step -1
    oTarget.Tables(i).Range.Rows.ConvertToText Separator:=wdSeparateByParagraphs, NestedTables:=True
  Next i
  
  'Get rid of empty paragraphs
  With oTarget.Range.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[^13]{1,}"
    .Replacement.Text = "^13"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = True
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute Replace:=wdReplaceAll
  End With
  
  'Convert to a table
  Set aTbl = oTarget.Range.ConvertToTable(Separator:=wdSeparateByParagraphs, NumColumns:=1)
  aTbl.Columns.Add BeforeColumn:=aTbl.Columns(1)
  aTbl.PreferredWidthType = wdPreferredWidthPercent
  aTbl.PreferredWidth = 100
  
  For Each aRow In aTbl.Rows
    Set oRng = aRow.Cells(2).Range
    oRng.End = oRng.End - 1
    aRow.Cells(1).Range.FormattedText = oRng.FormattedText
    Set oCC1 = oTarget.ContentControls.Add(wdContentControlRichText, aRow.Range.Cells(1).Range)
    oCC1.Color = wdColorRed
    oCC1.LockContentControl = True
    oCC1.LockContents = True
    Set oCC2 = oTarget.ContentControls.Add(wdContentControlRichText, aRow.Range.Cells(2).Range)
    oCC2.Range.LanguageID = wdEnglishAUS      'set your target language
  Next aRow

lbl_Exit:
  Exit Sub
End Sub

Sub FinishedProduct()
  Dim aCC As ContentControl
  For Each aCC In ActiveDocument.ContentControls
    aCC.LockContentControl = False
    aCC.Delete
  Next aCC
  If ActiveDocument.Tables.Count = 1 Then
    ActiveDocument.Tables(1).Columns(1).Delete
    ActiveDocument.Tables(1).Range.Rows.ConvertToText Separator:=wdSeparateByParagraphs
  End If
End Sub