#1
|
|||
|
|||
Merging of colums from two different docs & create a new doc
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. |
#2
|
||||
|
||||
Provided the two tables are the same size then
Code:
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
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com Last edited by gmayor; 08-14-2021 at 08:43 PM. |
#3
|
|||
|
|||
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 ..... |
#4
|
||||
|
||||
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 Code:
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
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#5
|
|||
|
|||
Thank you so much....
Your Help is highly appreciated and works like a treat.... |
#6
|
|||
|
|||
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.... |
#7
|
|||
|
|||
HI,
Please help me ..... Do the needful... Thanks in Advance.. |
#8
|
||||
|
||||
Change the line
Code:
If Not oTable1.Rows.Count = oTable2.Rows.Count Then GoTo lbl_Exit Code:
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 Code:
Set oSource = Documents.Open(sSource) Code:
oSource.AcceptAllRevisions
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#9
|
|||
|
|||
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..... |
#10
|
|||
|
|||
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 Last edited by ranjan; 08-31-2021 at 10:32 AM. Reason: Add: Sort by a length (large to small) |
Tags |
merging of colums |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Merging Word docs / PDFs while keeping external links | Daedalus | Word | 1 | 05-11-2015 07:37 AM |
Merging Various .docs Via Q&A | Wants_It_Simple | Word | 1 | 06-30-2014 10:26 PM |
How to create shorter docs from large base template? | Preloader | Word | 13 | 10-19-2013 09:39 PM |
Fields/Colums in folders | cilimpuli | Outlook | 1 | 03-10-2013 12:20 PM |
Is it possible to create 'balloon' text in docs | bubbleboi | Word | 3 | 11-13-2009 01:19 AM |