Merge tables from multiple documents into one table

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

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

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

Code:

---

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.

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

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

Code:

---

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

---