مساعده في كود ارتباط تشعبي

[محمد عبد الناصر]

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

اريد ان يقوم بعمل الكود وان لا ينفذ الامر على sheet2 و sheet7 و sheet3

وان يجعل حجم الخط في الخليه E1 في كل الشيتات 30 

Sub ww()


Dim h As Worksheet, sh As Worksheet, j As String
Dim k As String, x As String, d As String
Set h = Sheets("Sheet1")

For Each sh In Sheets
If Not sh.Name = "Sheet1" Then
j = sh.Index + 2
k = sh.Name
x = "'" & k & "'!a1"
d = "'Sheet1'!a1"
h.Hyperlinks.Add h.Cells(j, 1), "", x, k, k
sh.Hyperlinks.Add sh.Cells(1, 5), "", d, "Sheet1", "رجوع"
End If
Next

End Sub

 

تم تعديل نوفمبر 5, 2023 بواسطه محمد عبد الناصر

[محمد هشام.]

تفضل جرب 

 

Sub test()
Dim i As Integer
i = 2
For Each sh In ThisWorkbook.Worksheets
Select Case sh.Name
    Case Is = "Sheet1", "Sheet2", "Sheet3", "Sheet7" '<-----   'تجاهل الاوراق التالية
            Case Else
Application.ScreenUpdating = False
            
        ActiveWorkbook.Sheets("Sheet1").Hyperlinks.Add _
        Anchor:=ActiveWorkbook.Sheets("Sheet1").Cells(i, 1), _
        Address:="", _
        SubAddress:="'" & sh.Name & "'!A1", _
        TextToDisplay:=sh.Name
sh.Hyperlinks.Add Anchor:=sh.Range("E1"), Address:="", SubAddress:="Sheet1" & "!A1", TextToDisplay:="رجوع"
sh.Range("E1").Font.Size = 30: sh.Rows(1).AutoFit
    i = i + 1
    End Select

Next sh
Application.ScreenUpdating = True

End Sub

 

ارتباط تشعبي.xlsm

تم تعديل نوفمبر 7, 2023 بواسطه محمد هشام.

[أ / محمد صالح]

بعد إذن أخينا الفاضل محمد هشام

هذا الكود بنفس طريقتك

Sub ww()
Dim sh As Worksheet, i As Double: i = 2
For Each sh In Sheets
If sh.Name <> "Sheet1" And sh.Name <> "Sheet2" And sh.Name <> "Sheet3" And sh.Name <> "Sheet7" Then
Sheets("Sheet1").Hyperlinks.Add Sheets("Sheet1").Cells(i, 1), "", "'" & sh.Name & "'!a1", sh.Name, sh.Name
sh.Hyperlinks.Add sh.Cells(1, 5), "", "'Sheet1'!a1", "Sheet1", "رجوغ"
sh.Cells(1, 5).Font.Size = 30: i = i + 1
End If
Next
MsgBox "Dobe by mr-mas.com"
End Sub

رغم أني أعتقد كان من السهل على حضرتك عمل التعديل إن كنت حضرتك صاحب الكود

أما إن كنت استخدمت كود غيرك

فمن الواضح أنك لم تقم بمدارسته وفهمه

بالتوفيق

[محمد عبد الناصر]

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