طلب كود عمل قائمة باسماء الصفحات وعمل هايبر لينك لكل اسم

[gamalin2]

الاخوة الافاضل

ابحث عن كود لعمل قائمة بأسماء الصفحات في ملف اكسل يحتوي على كم كبير من الصفحات

وأريد عمل هايبر لينك لكل اسم في القئمة بالصفحة الخاصة بة ليسهل الوصول الى هذه الصفحات

ارجو المساعدة

مرفق ملف كنموذج فقط

 

h link.rar

[سليم حاصبيا]

جرب هذا الكود

 

Option Explicit
Sub Create_TOC()

Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim lnRow As Long
Dim lnCount As Long

Set wbBook = ActiveWorkbook
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next

   Sheets("TOC").Select       ' TOC (Table Of Contents)
   If Err.Number = 9 Then Sheets.Add Sheet1: ActiveSheet.Name = "TOC"
    ActiveSheet.Range("A2:a500").ClearContents
On Error GoTo 0


lnRow = 2
lnCount = 1
For Each wsSheet In wbBook.Worksheets
    If wsSheet.Name <> "TOC" Then
            With ActiveSheet
                .Hyperlinks.Add .Cells(lnRow, 1), "", _
                SubAddress:="'" & wsSheet.Name & "'!A1", _
                TextToDisplay:=wsSheet.Name
            End With
            lnRow = lnRow + 1
            lnCount = lnCount + 1
    End If
Next wsSheet

     With ActiveSheet.Range("a1:d500")
         .Font.Size = 20
         .Font.Bold = True
         .Columns("A:d").EntireColumn.AutoFit
      End With
      
      With ActiveSheet
        .Range("a1") = "المحتويات"
        .Range("c1") = "عدد الصفحات"
        .Range("d1") = lnCount - 1
     End With
     
     With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub

الملف مرفق

 

h link salim.rar

[gamalin2]

جزاك الله خيرا هو المطلوب تماما اشكرك