Merge tables from multiple documents into one table

[PatrickJH]

I thought I'd use this opportunity to say hello and also to ask for advice. I used to program in Basic and Visual Basic ages ago but want to develop my knowledge and skills in VBA. The immediate problem I am trying to solve is as follows.

1) I have a number of Word documents that contain tables in a consistent format with the following column headings: Date; Action; Who by. These contain chronologies of the actions taken by different organisations in a case that I am reviewing

2) I want to merge these together into a combined table using the same format (i.e. columns headed Date; Action; Who by) in such a way that it also combines them into a single chronology. Hopefully the following will give some idea of what I want to do:

Chronology 1


DATE
ACTION
WHO BY


1/1/2020
Visit to client at 10.30am
GP


3/1/2020
Repeat prescription written
GP



Chronology 2


DATE
ACTION
WHO BY


1/1/2020
Visit to client at 2pm
Social Services


5/1/2020
Telephone call to District Nurse
Social Services



Merger of chronology 1 and 2



DATE
ACTION
WHO BY


1/1/2020
Visit to client at 10.30am
GP


1/1/2020
Visit to client at 2pm
Social Services


3/1/2020
Repeat prescription written
GP


5/1/2020
Telephone call to District Nurse
Social Services



3) Has anyone written any code that does something like this already? If so could anyone please point me in the right direction?

Many thanks in advance

Patrick

[SamT]

Hey Patrick,
Welcome to the best VBA resource on the Internet.

Assuming that you want the result in Word, I moved this thread to the Word VBA forum

[macropod]

Try running the following macro from an empty Word document (or at least one with no tables):

Sub MergeChronologies()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strTgt As String
Dim wdDocTgt As Document, wdDocSrc As Document, Tbl As Table
strFolder = GetFolder: If strFolder = "" Then Exit Sub
Set wdDocTgt = ActiveDocument: strTgt = ActiveDocument.FullName
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
If strFolder & strFile <> strTgt Then
Set wdDocSrc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDocSrc
For Each Tbl In .Tables
wdDocTgt.Range.Characters.Last.FormattedText = Tbl.Range.FormattedText
Next
.Close SaveChanges:=False
End With
End If
strFile = Dir()
Wend
With wdDocTgt.Tables(1)
.SortAscending
Do While InStr(1, .Cell(2, 1).Range.Text, "date", vbTextCompare) > 0
.Rows(2).Delete
Loop
End With
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
Simply select the folder containing the files to process and all tables in those documents will be merged. Do note it is not practical to sort on your second column's times, as the data there are too mixed to guarantee a reliable sorting.

[PatrickJH]

Hi Macropod,

That's absolutely brilliant, thanks so much. After a bit of finding the right folder it worked perfectly. My task now is to make it run on Word on a MacBook.

Regards,

Patrick

[macropod]

For a Mac, you might be able to use something like the following to select the files to process:

Sub MergeChronologies()
Application.ScreenUpdating = False
Dim strSrc As String, strTgt As String, i As Long
Dim wdDocTgt As Document, wdDocSrc As Document, Tbl As Table
Set wdDocTgt = ActiveDocument: strTgt = ActiveDocument.FullName
With Application.FileDialog(FileDialogType:=msoFileDialogFilePicker)
.AllowMultiSelect = True
.Filters.Add "Documents", "*.doc; *.docx; *.docm", 1
.InitialFileName = ""
If .Show = -1 Then
For i = 1 To .SelectedItems.Count
strSrc = .SelectedItems(i)
If strSrc <> strTgt Then
Set wdDocSrc = Documents.Open(FileName:=strSrc, AddToRecentFiles:=False, Visible:=False)
With wdDocSrc
For Each Tbl In .Tables
wdDocTgt.Range.Characters.Last.FormattedText = Tbl.Range.FormattedText
Next
.Close SaveChanges:=False
End With
End If
Next
Else
GoTo ErrExit
End If
End With
With wdDocTgt.Tables(1)
.SortAscending
Do While InStr(1, .Cell(2, 1).Range.Text, "date", vbTextCompare) > 0
.Rows(2).Delete
Loop
End With
ErrExit:
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub