نسخ كل الجداول المعرفة في اكسل الي وورد تبعا للاشارات المرجعية

[جمال جبريل]

رغم انني وضعت سؤالا قبل ذلك ومن يجاوب احدا علينا رغم محترفين ، ولعل المانع خيرا.

لسؤال جديد عسى ان يهتم به احدا:
وجدت كود في المواقع الاجنبية ينسخ كل الجداول المعرفة في الاكسل الي وورد، في مستند جديد بحيث يكون كل جدول في صفحة ، وهذا هو الكود :

Sub CopyWorksheetsToWord()
' requires a reference to the Word Object library:' --- Comment
' in the VBE select Tools, References and check the Microsoft Word X.X object library' --- Comment
Dim tbl As ListObject
Dim wdApp As Word.Application, wdDoc As Word.Document, ws As Worksheet
Application.ScreenUpdating = False
Application.StatusBar = "Creating new document..."
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Add
For Each ws In ActiveWorkbook.Worksheets
Application.StatusBar = "Copying data from " & ws.Name & "..."
For Each tbl In ActiveSheet.ListObjects
tbl.Range.Copy
'ws.UsedRange.Copy ' or edit to the range you want to copy' --- Comment

wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.Paste

Application.CutCopyMode = False

wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
' insert page break after all worksheets except the last one' --- Comment
If Not ws.Name = Worksheets(Worksheets.Count).Name Then
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.InsertParagraphBefore
.Collapse Direction:=wdCollapseEnd
.InsertBreak Type:=wdPageBreak
'.InsertBreak Type:=7
End With
End If
Next tbl
Next ws
Set ws = Nothing
Application.StatusBar = "Cleaning up..."
' apply normal view' --- Comment
With wdApp.ActiveWindow
If .View.SplitSpecial = wdPaneNone Then
.ActivePane.View.Type = wdNormalView
Else
.View.Type = wdNormalView
End If
End With
Set wdDoc = Nothing
wdApp.Visible = True
Set wdApp = Nothing
Application.StatusBar = False
End Sub

ووجدت كود اخر ينسخ الاسماء المعرفة في الاكسل الي وورد ولكن يلصقها في اشارات مرجعية ، بحيث يكون كل اسم معرف يطابق اسم الاشارة المرجعية، وهذا الكود:
Option Explicit
Sub namesToBookmarks()
    Dim objWord As Object
    Dim docWord As Object
    Dim wb As Excel.Workbook
    Dim xlName As Excel.Name
    Dim Path As String

    Set wb = ActiveWorkbook
    Path = "C:\Users\jjebril\Desktop\MacroTest.docx"    ''///change the name

    On Error GoTo ErrorHandler

    ''///Create a new Word Session
    Set objWord = CreateObject("Word.Application")

    On Error GoTo ErrorHandler

    ''///Open document in word
    Set docWord = objWord.Documents.Add(Path)

    ''///Loop through names in the activeworkbook
    For Each xlName In wb.Names
        ''///if xlName''///s name is existing in document then put the value in place of the bookmark
        If docWord.Bookmarks.Exists(xlName.Name) Then
            docWord.Bookmarks(xlName.Name).Range.Text = Range(xlName.Value)
        End If
    Next xlName

    ''///Activate word and display document
    With objWord
        .Visible = True
        .ActiveWindow.WindowState = 0
        .Activate
    End With

    ''///Release the Word object to save memory and exit macro
ErrorExit:
    Set objWord = Nothing
    Exit Sub

    ''///Error Handling routine
ErrorHandler:
    If Err Then
        MsgBox "Error No: " & Err.Number & ": an error occurred"
        If Not objWord Is Nothing Then
            objWord.Quit False
        End If
        Resume ErrorExit
    End If
End Sub

اريد فقط نسخ كل الجداول الموجودة في الاكسل ولصقها في وورد ولكن تبعا للاشارات المرجعية التي لها نفس اسماء الجداول مثل المثال الثاني.
يعني المثال اول ننسخ كل الجداول المعرفة الي وورد ولكن تبعا للاشارات المرجعية في وورد والتي بنفس اسماء الجداول المعرفة في اكسل
ولكم جزيل الشكر.

تم تعديل يناير 20, 2017 بواسطه جمال الخطيب