البحث في الموقع

رغم انني وضعت سؤالا قبل ذلك ومن يجاوب احدا علينا رغم محترفين ، ولعل المانع خيرا. لسؤال جديد عسى ان يهتم به احدا: وجدت كود في المواقع الاجنبية ينسخ كل الجداول المعرفة في الاكسل الي وورد، في مستند جديد بحيث يكون كل جدول في صفحة ، وهذا هو الكود : 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 اريد فقط نسخ كل الجداول الموجودة في الاكسل ولصقها في وورد ولكن تبعا للاشارات المرجعية التي لها نفس اسماء الجداول مثل المثال الثاني. يعني المثال اول ننسخ كل الجداول المعرفة الي وورد ولكن تبعا للاشارات المرجعية في وورد والتي بنفس اسماء الجداول المعرفة في اكسل ولكم جزيل الشكر.