gather all Tables to one file

Hi all,

well i'm in bad situation in dealing with huge number of files for translation in docx files

i'm trying to find a code that can go through defined path folder by prompt window or anything else,

Attachment 25396

then copy the 4th table as shown below

Attachment 25394

and gather all of tables to the first file and separate between them by a paragraph mark

Attachment 25395


i have attached sample files for before and after




Many thanks in advance

Cheers

any help would be appreciated, i got a code that can copy specific table to a new document but i couldn't make it go through multiple files with the separator and when it copy a table it doesn't copy the format, table and cell sizes well.

Quote:

---

Sub ExtractSpecificTables()Dim objTable As Table
Dim objDoc As Document
Dim objNewDoc As Document
Dim objRange As Range
Dim strTable As String


strTable = InputBox("Enter the table number: ")
Set objDoc = ActiveDocument
Set objNewDoc = Documents.Add


objDoc.Tables(strTable).Range.Select
Selection.Copy


Set objRange = objNewDoc.Range
objRange.Collapse Direction:=wdCollapseEnd
objRange.PasteSpecial DataType:=wdPasteRTF


End Sub

---

What you require is fairly straightforward it is just a matter of looping through the files and pasting the tables into a new document based on one of the files (without its content) e.g. as follows. The only complication is the locked content controls in the document used as template.

Code:

---

Sub GetTables()Dim strFile As String
Dim strPath As String
Dim oDoc As Document, oTarget As Document
Dim oRng As Range
Dim fDialog As FileDialog
Dim i As Integer
Dim oCC As ContentControl
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With fDialog
        .TITLE = "Select folder and click OK"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then
            MsgBox "Cancelled By User", , "List Folder Contents"
            Exit Sub
        End If
        strPath = fDialog.SelectedItems.Item(1)
        If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
    End With
    i = 1
    strFile = Dir$(strPath & "*.do?")
    While strFile <> ""
        If i = 1 Then
            Set oTarget = Documents.Add(Template:=strPath & strFile)
            For Each oCC In oTarget.ContentControls
                oCC.LockContentControl = False
            Next oCC
            oTarget.Range.Text = ""
        End If
        Set oDoc = Documents.Open(FileName:=strPath & strFile, AddToRecentFiles:=False)
        If oDoc.Tables.Count > 3 Then
            oDoc.Tables(4).Range.Copy
            Set oRng = oTarget.Range
            oRng.Collapse 0
            oRng.PasteAndFormat wdFormatOriginalFormatting
            oRng.End = oTarget.Range.End
            oRng.Collapse 0
            oRng.Text = vbCr
        End If
        oDoc.Close SaveChanges:=wdDoNotSaveChanges
        i = i + 1
        DoEvents
        strFile = Dir$()
    Wend
lbl_Exit:
    Set oDoc = Nothing
    Exit Sub
End Sub

---

Dear Graham,

Many thanks for your reply. but i tried your code and it seems doesn't work to me.

i got a window to select the folder then i choose it but no thing happened after that!!

did you test it on my attached files?

looking forward to your reply and many thanks in advance for your generous help

This forum seems to randomly remove line breaks. The first line

Code:

---

Sub GetTables()Dim strFile As String

---

should be

Code:

---

Sub GetTables()
Dim strFile As String

---

and yes it works with your example files - attached.

yes i know about the line break but it didn't work to me until i tried on another Labtop, i guess my office has an issue.


3000 Thousands thanks Graham, you made my day :clap::clap::clap:

Cheers