نسخ كل الجداول من مجلد معين إلى ملف واحد:

[أبو عاصم المصري]

نحتاج أحيانا إلى حصر كل الجداول الموجودة ضمن ملفات متعددة للنظر فيها على حدة.

وهذا ماكرو يبحث داخل الملفات التي تحددها داخل مجلد معين، فينسخ الجداول فقط، ثم يضعها في ملف مستقل لتنظر فيها.

وهذا الماكرو:

' نسخ الجداول من مجلد معين ووضعها في ملف واحد
Dim strFileName As String
Dim strPath As String
Dim oDoc As Document, oNewdoc As Document
Dim oTable As Range, oRng As Range
Dim oLog As Document
Dim bFound As Boolean
Dim fDialog As FileDialog
Dim oColl As New Collection
Dim i As Long, j As Long, k As Long
On Error Resume Next
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With fDialog
        .Title = "حدد المجلد وانقر فوق موافق "
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then
            MsgBox "أُلغي الأمر", , _
                   "محتويات المجلد"
            GoTo lbl_Exit
        End If
        strPath = fDialog.SelectedItems.Item(1) & Chr(92)
    End With
    Set oNewdoc = Documents.Add

    strFileName = Dir$(strPath & "*.doc")

    While Len(strFileName) <> 0
        Set oDoc = Documents.Open(filename:=strPath & strFileName, AddToRecentFiles:=False)
        bFound = False
        If oDoc.ProtectionType = wdNoProtection Then
            If oDoc.Tables.Count > 0 Then
                k = 0
                bFound = True
                For i = 1 To oDoc.Tables.Count
                    Set oTable = oDoc.Tables(i).Range
                    oTable.Copy
                    Set oRng = oNewdoc.Range
                    oRng.Collapse 0
                    oRng.InsertParagraphAfter
                    Set oRng = oNewdoc.Range
                    oRng.Collapse 0
                    oRng.Paste
                    k = k + 1
                    DoEvents
                Next i
                If bFound = True Then
                    oColl.Add strFileName & vbTab & k & " tables copied"
                End If
            End If
            DoEvents
        End If
        oDoc.Close SaveChanges:=wdDoNotSaveChanges
        strFileName = Dir$()
    Wend
    Set oLog = Documents.Add
    For j = 1 To oColl.Count
        oLog.Range.InsertAfter oColl(j) & vbCr
    Next j
lbl_Exit:
    Exit Sub
Beep
End Sub