Search code examples
vbams-wordcopy-paste

Copy/paste subsequent paragraphs from two Word documents one after another (to learn a foreign language)


I have two books of the same title: one English, one Spanish. I want to combine them so I can learn Spanish. So I need a single Word document that has one paragraph in English, followed by the same paragraph in Spanish, over and over again. Below is what I have from manually copy/pasting, but I would like to automate it using a patter of (a) copy/pasting by paragraph break, or (b) copy/pasting every 350 characters (or 100 words) with a punctuation being the end point. This is what I have so far:

Sub Macro1()
    Windows("3.doc  -  Compatibility Mode").Activate
    Selection.MoveDown Unit:=wdLine, Count:=13, Extend:=wdExtend
    Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
    Selection.Copy
    Windows("Document2").Activate
    Windows("656398.docx  -  Compatibility Mode").Activate
    Selection.PasteAndFormat (wdFormatOriginalFormatting)
    Selection.MoveDown Unit:=wdLine, Count:=23, Extend:=wdExtend
    Selection.MoveUp Unit:=wdLine, Count:=7, Extend:=wdExtend
    Selection.MoveDown Unit:=wdLine, Count:=3, Extend:=wdExtend
    Selection.Copy
    Windows("Document2").Activate
    Windows("3.doc  -  Compatibility Mode").Activate
    Selection.PasteAndFormat (wdPasteDefault)
    Selection.MoveDown Unit:=wdLine, Count:=8, Extend:=wdExtend
    Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
    Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
    Selection.MoveLeft Unit:=wdCharacter, Count:=2, Extend:=wdExtend
    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.Copy
    Windows("Document2").Activate
    Windows("656398.docx  -  Compatibility Mode").Activate
    Selection.PasteAndFormat (wdFormatOriginalFormatting)
    Selection.MoveDown Unit:=wdLine, Count:=18, Extend:=wdExtend
    Selection.Copy
    Windows("Document2").Activate
    Selection.MoveDown Unit:=wdLine, Count:=1
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.PasteAndFormat (wdUseDestinationStylesRecovery)
    ActiveDocument.Save
End Sub

Solution

  • For example, provided the documents have exactly the same paragraphing:

    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
    

    The combined document will be saved in the docx format with the same name as the first document you open, with '-Combined' added to the filename.