كيفية التنقل بين الخلايا ( الهايبر لينك)

[محمود احمد]

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

اخواني الكرام ارغب في المساعدة لعمل هايبر لينك لاعداد كثيرة ..اعلم الطريقة المعتادة ولكن ارغب في طريقة اخري سهلة التعلم والتطبيق علي اكواد كثيرة تصل للالف

مرفق لحضراتكم ملف به المطلوب بشكل اكثر توضيحا فهل هناك طريقة 

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

هايبر لينك لاعداد كثيرة.rar

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

جرب هذا الكود

يجب تغيير اسم الصفحة الى "jan" ,وذلك لحسن التعامل مع اللغة الاجنبية

(و لا اعلم لماذا حملت الملف كله كان يكفي حوالي 100 صف   -كنموذج)

Sub find_for_me()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

If ActiveSheet.Name <> "jan" Then GoTo 1
Set my_sh = Sheets("jan")
Dim FoundCell As Range
Dim LastCell As Range
Dim FirstAddr, My_string As String
My_string = "المبيعات"
my_sh.Range("H2:H50000").Clear
Set FoundCell = my_sh.Range("d:d").Find(what:=My_string, after:=my_sh.Cells(1, 4), lookat:=xlPart)
If Not FoundCell Is Nothing Then FirstAddr = FoundCell.Address
t = 1
Do Until FoundCell Is Nothing
 Cells(m + 2, 8) = FoundCell.Row - 1
 Cells(FoundCell.Row - 1, 4) = t
 m = m + 1
 t = t + 1

     Set FoundCell = Range("D:D").FindNext(after:=FoundCell)
    If FoundCell.Address = FirstAddr Then Exit Do
          
Loop
    '==============================
      k = 2
      Do Until Cells(k, "h") Is Nothing
       ActiveSheet.Hyperlinks.Add Anchor:=Cells(k, "h"), Address:="", SubAddress:= _
        "jan!E" & Cells(k, "h").Value, ScreenTip:="GOTO E" & Cells(k, "h").Value
        k = k + 1
     Loop
      '=====================
1:
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

مرفق الملف مع الكود

Hyper_Salim.rar

تم تعديل مارس 28, 2017 بواسطه سليم حاصبيا

[محمود احمد]

شكرا لك استاذي الفاضل  ... هذا ماكنت اريده ..تسلم ايدك بجد والف شكر علي مجهودك وتعبك... جعل الله نشر علمك في ميزان حسناتك

واعتذر عن السهو في رفع الملف بأكمله