gather all Tables to one file

[Ethen5155]

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,

25396

then copy the 4th table as shown below

25394

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

25395


i have attached sample files for before and after




Many thanks in advance

Cheers

[Ethen5155]

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.



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

[gmayor]

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.


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

[Ethen5155]

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

[gmayor]

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

Sub GetTables()Dim strFile As String
should be

Sub GetTables()
Dim strFile As String
and yes it works with your example files - attached.

[Ethen5155]

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