طلب تعديل كود

[أيهاب ممدوح]

السلام عليكم

يوجد لدي كود يعمل في صفحه الحدث

الرجاء جعله يكون كود بحيث ان يتم العمل به عند اللزوم وليس كل مره ادخل الصفحه يقوم بالتحديث ويأخد وقت

Option Explicit
Dim check%

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Columns(1)) Is Nothing _
    And Target.Count = 0 Then
      Call IsHyperlink(Target)
        If check Then
         Sheets(Target & "").Visible = True
        Target.Hyperlinks(1).Follow
        End If
End If
Application.EnableEvents = True
End Sub
Sub IsHyperlink(r As Range)
check = r.Hyperlinks.Count
End Sub
Private Sub Worksheet_Activate()
Dim wSheet As Worksheet
Dim l As Long
l = 1
With Me
.Columns(1).ClearContents
.Cells(1, 1) = "اسماء المنتجات"
.Cells(1, 1).Name = "Index"
End With
For Each wSheet In Worksheets
If wSheet.Name <> Me.Name Then
l = l + 1
With wSheet
.Range("A1").Name = "Start" & wSheet.Index
.Hyperlinks.Add Anchor:=.Range("d1"), Address:="", SubAddress:= _
"Index", TextToDisplay:="الرئيسية"
End With
Me.Hyperlinks.Add Anchor:=Me.Cells(l, 1), Address:="", _
SubAddress:="Start" & wSheet.Index, TextToDisplay:=wSheet.Name
End If
Next wSheet
 With Me.Range("A:A").Font
        .ColorIndex = xlAutomatic
        .Bold = True: .Underline = 1
        .Name = "Arial": .Size = 12
 End With
    
End Sub

 

المصنف1.xlsm

تم تعديل منذ 1 ساعه بواسطه أيهاب ممدوح
ارفاق ملف