Merging of colums from two different docs & create a new doc

[ranjan]

Hi,



I want to create a new doc by replacing a colums from two different docs, for more details please look into the attachment.

Is it possible through VBA macro, it will more helpful for me...

Thanks in advance & do the needful.

[gmayor]

Provided the two tables are the same size then

Sub Macro1()
'Graham Mayor - https://www.gmayor.com - Last updated - 14 Aug 2021
Dim oSource As Document, oTarget As Document
Dim oTable1 As Table, oTable2 As Table
Dim oRng1 As Range, oRng2 As Range
Dim i As Long
    Set oTarget = Documents.Add("C:\Path\Doc A.docx")
    Set oSource = Documents.Open("C:\Path\Doc B.docx")
    Set oTable1 = oSource.Tables(1)
    Set oTable2 = oTarget.Tables(1)
    For i = 4 To oTable1.Rows.Count
        Set oRng1 = oTable1.Cell(i, 3).Range
        oRng1.End = oRng1.End - 1
        Set oRng2 = oTable2.Cell(i, 3).Range
        oRng2.End = oRng2.End - 1
        oRng2.FormattedText = oRng1.FormattedText
        If oRng2.Text = "" Then
            oRng2.Text = "###"
            oRng2.Font.Name = "Times New Roman"
            oRng2.Font.Size = 22
        End If
    Next i
lbl_exit:
    oSource.Close 0
    Set oTarget = Nothing
    Set oSource = Nothing
    Set oTable1 = Nothing
    Set oTable2 = Nothing
    Set oRng1 = Nothing
    Set oRng2 = Nothing
    Exit Sub
End Sub

[ranjan]

Thank you so much, works a treat, your help is highly appreciated...

I had one issue with the file selection location, if you add selection of source file (A) from a browse option and target file (B) from a browse option it would be easier. location is more dynamic and after merging the file and creating a new file & file should be saved in the save path or browse option to save the created file with the same file name of file "B" adding "_Reviewed".

File Name: A
File Name: B

New created file in the same path or browse to save the file with file name as B_Reviewed

from the above options it would be more easy and flexible to merge columns from any location.

Thanks you so much.... Your help is highly appreciated .....

[gmayor]

It's a bit more complicated and needs more error handling to browse for the two documents, but the following should work
IMPORTANT NOTE! The source file is B and the target file is A. The resulting file is A_Reviewed.docx

Option Explicit

Sub Macro1()
'Graham Mayor - https://www.gmayor.com - Last updated - 15 Aug 2021
Dim oSource As Document, oTarget As Document
Dim oTable1 As Table, oTable2 As Table
Dim oRng1 As Range, oRng2 As Range
Dim i As Long
Dim sName As String, sSource As String
    On Error GoTo lbl_Exit
    sName = BrowseForFile("Select Target document")
    If sName = "" Then
        MsgBox "User cancelled"
        GoTo lbl_Exit
    End If
    Set oTarget = Documents.Add(sName)

    sSource = BrowseForFile("Select Source document")
    If sSource = "" Then
        MsgBox "User cancelled"
        oTarget.Close 0
        GoTo lbl_Exit
    End If
    Set oSource = Documents.Open(sSource)

    If oSource.Tables.Count > 0 Then
        Set oTable1 = oSource.Tables(1)
    Else
        MsgBox "Document has no table", vbCritical
        GoTo lbl_Exit
    End If
    If oTarget.Tables.Count > 0 Then
        Set oTable2 = oTarget.Tables(1)
    Else
        MsgBox "Document has no table", vbCritical
        GoTo lbl_Exit
    End If
    If Not oTable1.Rows.Count = oTable2.Rows.Count Then GoTo lbl_Exit
    For i = 4 To oTable1.Rows.Count
        Set oRng1 = oTable1.Cell(i, 3).Range
        oRng1.End = oRng1.End - 1
        Set oRng2 = oTable2.Cell(i, 3).Range
        oRng2.End = oRng2.End - 1
        oRng2.FormattedText = oRng1.FormattedText
        If oRng2.Text = "" Then
            oRng2.Text = "###"
            oRng2.Font.Name = "Times New Roman"
            oRng2.Font.Size = 22
        End If
    Next i
    sName = Left(sName, InStrRev(sName, Chr(46)) - 1) & "_Reviewed.docx"
    oTarget.SaveAs2 sName
lbl_Exit:
    If Not oSource Is Nothing Then oSource.Close 0
    Set oTarget = Nothing
    Set oSource = Nothing
    Set oTable1 = Nothing
    Set oTable2 = Nothing
    Set oRng1 = Nothing
    Set oRng2 = Nothing
    Exit Sub
End Sub

Private Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
'Graham Mayor
'strTitle is the title of the dialog box
'Set bExcel value to True to filter the dialog to show Excel files
'The default is to show Word files
Dim fDialog As FileDialog
    On Error GoTo err_Handler
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .Title = strTitle
        .AllowMultiSelect = False
        .Filters.Clear
        If bExcel Then
            .Filters.Add "Excel workbooks", "*.xls,*.xlsx,*.xlsm"
        Else
            .Filters.Add "Word documents", "*.doc,*.docx,*.docm"
        End If
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then GoTo err_Handler:
        BrowseForFile = fDialog.SelectedItems.Item(1)
    End With
lbl_Exit:
    Exit Function
err_Handler:
    BrowseForFile = vbNullString
    Resume lbl_Exit
End Function

[ranjan]

Thank you so much....

Your Help is highly appreciated and works like a treat....

[ranjan]

Now am getting issue with replacing a decriptions with mismatches rows from file A & file B.

If there is mismatch like A flle has 20 rows and B has 21 rows & likewise A file has 22 rows and B has 20 rows then throw a error "mismatch exists please review manually".

It should proceeds only if there is equal rows in file A & file B, otherwise throw a error message.

&

Can we incorparte accpt all the changes in file B before taking into merging...

ActiveDocument.AcceptAllRevisions


After accepting changes then creating a review version.

Please review and do the needdul...

Thanks in advance...

Your help is highly appreciated....

[ranjan]

HI,

Please help me .....

Do the needful...

Thanks in Advance..

[gmayor]

Change the line

If Not oTable1.Rows.Count = oTable2.Rows.Count Then GoTo lbl_Exit

to

If Not oTable1.Rows.Count = oTable2.Rows.Count Then
    MsgBox "The tables do not have the same number of rows", vbCritical
    GoTo lbl_Exit
End If

Directly after the line

Set oSource = Documents.Open(sSource)

add the line

 oSource.AcceptAllRevisions

[ranjan]

Thank you so much, it works well..

I appreciate your time and support.

Thank you so much for your time, expertise, and patience. I am grateful for all the effort you have put in this work.....

[ranjan]

Hi,

I want to sort the fields from Descending to Ascending by a string length (Largest to smallest) before replacing on the target document, i had applied the below command but its not working can anyone review this...

Below highlighted is inserted in the above code if anything wrong please rectify..

.Text = Split(Tbl.Cell(r, 2).Range.Text, vbCr)(0)
.Replacement.Text = Split(Tbl.Cell(r, 3).Range.Text, vbCr)(0)
.SortOrder=wdSortOrderDescending
.Execute Replace:=wdReplaceAll

For Reference : 2 Smart Ways to Sort a Column of Texts by Length in Your Word - Data Recovery Blog