كود عمل الارتبات التشعبيه للشيتات

[على حسن]

السلام عليكم ورحمة الله وبركاته

الكود يقوم بعمل الارتباطات التشعبيه للشيتات

لكن للاسف يقوم بعمل للارتباطات للاسم الواحد فقط

الشيتات

محمد

احمد

على

اسماعيل    الكود يعمل

اما محمد على فيعطى رسالة المرجع غير صحيح وذلك لان الشيت به اسمان

المطلوب جعل الكودِ يعمل على الاسم والاسمان والثلاثه ايضا

عمل الارتباطات التشعبيه.rar

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

جرب هذا الماكرو

Option Explicit
Sub Create_TOC()
Application.ScreenUpdating = False
Dim wbBook As Workbook
Dim wsActive As Worksheet
Dim wsSheet As Worksheet
Dim lnRow As Long

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

    Sheets("الرئيسيه").Select
    ActiveSheet.Range("A2:A500").ClearContents

On Error GoTo 0
Set wsActive = wbBook.ActiveSheet
lnRow = 2

For Each wsSheet In wbBook.Worksheets
    If wsSheet.Name <> wsActive.Name Then

        With wsActive
            .Hyperlinks.Add .Cells(lnRow, 1), "", _
            SubAddress:="'" & wsSheet.Name & "'!A1", _
            TextToDisplay:=wsSheet.Name
        End With
        lnRow = lnRow + 1
    
    End If
Next wsSheet
wsActive.Activate

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With


 With ActiveSheet.Range("a1:a500")
        With .Font
             .Size = 16
             .Bold = True
             .Underline = False
         End With
    .EntireColumn.AutoFit
    .Range("a1").Select
 End With
Application.ScreenUpdating = True
End Sub

 

[على حسن]

جزاك الله خيرا 

استاذى العزيز سليم حاصبيا

وجعله الله فى ميزان حسنانتك ان شاء الله