Microsoft Office Forums - View Single Post - [Solved] Word macro: copy from different tables into one table

macropod · 03-25-2014, 01:22 AM

Try the following. It should work with any number of columns. Although there's nothing in the code to ensure all rows end up being the same width, that won't matter if they are in fact the same width. The macro you run is the top one: "Main"; it includes its own folder browser and will process all files in the selected folder and the folders below it. It also outputs a report of any files it can't process because of protection and the like.

Code:

Option Explicit
Public FSO As Object 'a FileSystemObject
Public oFolder As Object 'the folder object
Public oSubFolder As Object 'the subfolders collection
Public oFiles As Object 'the files object
Public i As Long, j As Long
Public DocTgt As Document
 
Sub Main()
' Minimise screen flickering
Application.ScreenUpdating = False
Dim StrFolder As String
' Browse for the starting folder
StrFolder = GetTopFolder
If StrFolder = "" Then Exit Sub
' Initialize the counters
i = 0: j = 0
' Search the top-level folder
Set DocTgt = Documents.Add()
Call GetFolder(StrFolder & "\")
' Search the subfolders for more files
Call SearchSubFolders(StrFolder)
' Return control of status bar to Word
Application.StatusBar = ""
' Restore screen updating
Application.ScreenUpdating = True
MsgBox i & " of " & j & " files processed.", vbOKOnly
End Sub
 
Function GetTopFolder() As String
GetTopFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetTopFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
 
Sub SearchSubFolders(strStartPath As String)
If FSO Is Nothing Then
  Set FSO = CreateObject("scripting.filesystemobject")
End If
Set oFolder = FSO.GetFolder(strStartPath)
Set oSubFolder = oFolder.subfolders
For Each oFolder In oSubFolder
  Set oFiles = oFolder.Files
  ' Search the current folder
  Call GetFolder(oFolder.Path & "\")
  ' Call ourself to see if there are subfolders below
  SearchSubFolders oFolder.Path
Next
End Sub
 
Sub GetFolder(StrFolder As String)
Dim strFile As String
strFile = Dir(StrFolder & "*.doc")
' Process the files in the folder
While strFile <> ""
  ' Update the status bar is just to let us know where we are
  Application.StatusBar = StrFolder & strFile
  Call UpdateFile(StrFolder & strFile)
  strFile = Dir()
Wend
End Sub
 
Sub UpdateFile(strDoc As String)
Dim Doc As Document
' Open the document
Set Doc = Documents.Open(strDoc, AddToRecentFiles:=False, ReadOnly:=False, Format:=wdOpenFormatAuto, Visible:=False)
With Doc
  If .ProtectionType = wdNoProtection Then
    Call GetTableData(Doc)
    ' Update the file counter for processed files
    i = i + 1
  Else
    ' Output a 'protected' file report in the document from which the macro is run.
    ThisDocument.Range.InsertAfter vbCr & strDoc & " protected. Not updated."
  End If
  ' Update the main file counter
  j = j + 1
  .Close SaveChanges:=False
End With
' Let Word do its housekeeping
DoEvents
Set Doc = Nothing
End Sub
 
Sub GetTableData(Doc As Document)
Dim Tbl As Table, i As Long, Rng As Range
With Doc
  For Each Tbl In .Tables
    For i = 1 To Tbl.Rows.Count
      Set Rng = Tbl.Cell(i, 2).Range
      Rng.End = Rng.End - 1
      If Rng.Text = "Yes" Then
        Set Rng = Tbl.Rows(i).Range
        DocTgt.Characters.Last.FormattedText = Rng.FormattedText
      End If
    Next
  Next
End With
End Sub