CODEWITHSUNDEEP
vbams-wordvba7
pmugzz
pmugzz

Reputation: 1

Copy/paste paragraphs in alternating manner from two Word documents into a different document (to learn a foreign language)

I have two documents in different languages (same number and format of paragraphs). I would like to create a third document from the 2 with the paragraphs alternating one after the other (to learn foreign language). The documents also have tables. I have tried using the code below, which I got from here (Copy/paste subsequent paragraphs from two Word documents one after another (to learn a foreign language)), but it fails on tables with the Run-time error '5251': This is not a valid action for the end of a row.

How can I make it run through the tables as well, alternating the paragraphs?

Sub AddSecondLanguage()
Application.ScreenUpdating = False
Dim DocA As Document, DocB As Document, Rng As Range, i As Long
With Application.FileDialog(FileDialogType:=msoFileDialogFilePicker)
  .Title = "Select the source document containing the primary language."
  .InitialFileName = "C:\Users\" & Environ("Username") & "\Documents\"
  .AllowMultiSelect = False
  If .Show = -1 Then
    Set DocA = Documents.Open(.SelectedItems(1), ReadOnly:=True, AddToRecentFiles:=False)
  Else
    MsgBox "No primary language file selected. Exiting.", vbExclamation: Exit Sub
  End If
End With
With Application.FileDialog(FileDialogType:=msoFileDialogFilePicker)
  .Title = "Select the source document containing the secondary language."
  .InitialFileName = DocA.Path & "\"
  .AllowMultiSelect = False
  If .Show = -1 Then
    Set DocB = Documents.Open(.SelectedItems(1), ReadOnly:=False, AddToRecentFiles:=True)
  Else
    MsgBox "No secondary language file selected. Exiting.", vbExclamation
    DocA.Close SaveChanges:=False: Set DocA = Nothing: Exit Sub
  End If
End With
With DocB
  For i = .Paragraphs.Count To 1 Step -1
    Set Rng = .Paragraphs(i).Range
    Rng.Collapse wdCollapseStart
    Rng.FormattedText = DocA.Paragraphs(i).Range.FormattedText
  Next
    .SaveAs2 FileName:=Split(DocA.FullName, ".doc")(0) & "-Combined.docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
End With
DocA.Close SaveChanges:=False
Set DocA = Nothing: Set DocB = Nothing
Application.ScreenUpdating = True
End Sub

Upvotes: 0

Views: 91

Answers (1)

macropod
macropod

Reputation: 13505

Try changing:

Dim DocA As Document, DocB As Document, Rng As Range, i As Long

to:

Dim DocA As Document, DocB As Document, RngSrc As Range, RngTgt As Range, i As Long

and changing:

  For i = .Paragraphs.Count To 1 Step -1
    Set Rng = .Paragraphs(i).Range
    Rng.Collapse wdCollapseStart
    Rng.FormattedText = DocA.Paragraphs(i).Range.FormattedText
  Next

to:

  For i = .Paragraphs.Count To 1 Step -1
    Set RngTgt = .Paragraphs(i).Range
    RngTgt.Collapse wdCollapseStart
    Set RngSrc = DocA.Paragraphs(i).Range
    If RngSrc.Information(wdWithInTable) = True Then
      If RngSrc.End <> RngSrc.Rows(1).Range.End Then
        If RngSrc.End = RngSrc.Cells(1).Range.End Then
          RngSrc.InsertAfter vbCr: RngSrc.End = RngSrc.End - 1
        End If
    Else
      RngTgt.FormattedText = RngSrc.FormattedText
    End If
  Next

Upvotes: 0

Related Questions