كود الهايبر لنك Hyper Link

[محمد الزريعي]

شرح كود الهايبر لنك.rar

[محمد الزريعي]

شباب مساكم الله بالخير والعافية 

قمت بشرح كود الهايبر لنك ،، والكود شغال 100% . لكن هناك مشكلة عندي اما في الجهاز او في الكود مش عارف أنه أذا وصل الي العمود d  يوقف في الوسط .. 

نرجوا التكرم منكم بالمساعدة في الحل . 

 

[عبد العزيز البسكري]

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

بارك الله فيك أخي الفاضل " محمّد الزريعي "

الكود عندي أنا شغّال في جميع الأعمدة من A لغاية العمود D وما جاورَهُ

فائق إحتراماتي

[محمد الزريعي]

اخي عبدالعزيز .. الله يحفظك ..  كلامك صحيح .. لكنني واضع الكود  أنا من A وحتى Z  أي  اريده يتنفذ كما هو في العمود a  حيث يبداء في العمود A  وينتهي في العمود  Z  .

لكن للاسف الكود يقوم بالتنفيذ في العمود a ثم b ثم c ثم d يتوقف عند  الصف رقم  12803

ما يتابع حتى يصل الي z 

تم تعديل نوفمبر 26, 2015 بواسطه محمد الزريعي

[عبد العزيز البسكري]

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

أخي الكريم " محمّد الزريعي " بما أنّك تبحث بهذا الموضوع .. سأشاركك في ذلك بهذا الملف للدخول إلى صفحات الويب عبر الشّيت أو عبر اليوزرفورم ..يكفي إدخال عنوان الصّفحات بطريقة سهلة و سلسلة

فائق إحتراماتي

 

 

الهايبر لينك عبر اليوزرفورم.rar

[محمد الزريعي]

مشاركتك .. جميلة جداً  ومختصرة  لمن يريد الانتقال الي صفحة الويب من اليوزرفور. 

الله يسعدك ويجعلها في ميزان حسناتك .

 

لكن يبقى حل المشكلة السابقة لم ينتهي  دوخت راسي عندما لا تجد في الكود خطاء وتجد الكود يقف من نفسة 

[ياسر خليل أبو البراء]

أخي الكريم محمد الزريعي

فيما يبدو لي أن هناك حد أقصي لعدد الارتباطات التشعبية Hyperlinks والحد الأقضى هو 65530... وذلك في كل الإصدارات ...

للأسف لن تتمكن من تنفيذ الكود وسيتوقف عند نفس النقطة في كل مرة ..

للتأكد من صحة كلامي قم بتحديد الأعمدة التي بها الارتباطات وانظر في شريط الحالة لترى الرقم بنفسك 65531 ..الارتباط الأخير توقف !!! زاد عن الحد

أرجو أن تكون المعلومة قد أنهت المشكلة لديك وعرفت سبب المشكلة حتى ترتاح رأسك اللي دوختها !!

وفي انتظار رأي بقية الخبراء

[الـعيدروس]

السلام عليكم

بالامكان استخدام كودك بالشكل التالي 

Sub MAS()
Application.ScreenUpdating = False
Set sh1 = Sheets("1")
Set sh2 = Sheets("2")
Dim x As Integer '  x= تمشي بشكل عمودي ينتقل من صف الي اخر ولكن بنفس العمود
Dim y As Integer '  y= تمشي بشكل افقي بعد الانتهاء من العمود الاول تنتقل للعمود الثاني بشكل صفوف
Dim z As Integer 'هي القيمة العددية التي تتناقص
         For a = 1 To 16
            fa = sh1.Range("a" & a)
             sn = 0
                For b = 1 To 26
                   fb = sh1.Range("a" & b)
                    For c = 1 To 26
                       fc = sh1.Range("a" & c)
                         For d = 1 To 26
                            fd = sh1.Range("a" & d)
                            sn = sn + 1
                            ww = fa & fb & fc & fd
                              sh2.Cells(sn, a) = "http://www." & ww & ".com"
                         Next d
                    Next c
                Next b
         Next a
'------------------------------------------------------------------------------------------------------
sh2.Activate
Application.ScreenUpdating = True
End Sub

وهذا الكود في حدث الورقة المسماه 2

بحيث عند النقر دبل كليك على اي خليه ينشاء Hyperlink في الخليه

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Not Intersect(Target, ActiveSheet.UsedRange) Is Nothing Then
   With ActiveSheet
       .Hyperlinks.Add Anchor:=Target, Address:=Target, SubAddress:="", TextToDisplay:=CStr(Target.Text)
   End With
 End If
End Sub

او عند النقر مباشره على اي خليه ينشاء Hyperlink في الخليه

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect(Target, ActiveSheet.UsedRange) Is Nothing Then
   With ActiveSheet
       .Hyperlinks.Add Anchor:=Target, Address:=Target, SubAddress:="", TextToDisplay:=CStr(Target.Text)
   End With
 End If
End Sub

 

تم تعديل نوفمبر 27, 2015 بواسطه الـعيدروس

[ياسر خليل أبو البراء]

أخي الحبيب أبو نصار

مش عارف أجمع المشاركة بشكل كويس ..

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

 ...

أعتقد أنه لا ترابط بينهما ..

يرجى التوضيح وإرفاق ملف كمثال

[الـعيدروس]

السلام عليكم

اخي ياسر خليل

ماقصدت الوصول اليه

بهذا الشكل كي تتضح لديك الصورة

اي اننا لن نصل للحد الاعلى من الهيبر لينك

   نستخدم الخليه الحاليه هيبرلينك ومجرد استخدامنا للخليه الحاليه نحذف السابق

    ارجو ان وصلت الفكره

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Not Intersect(Target, ActiveSheet.UsedRange) Is Nothing Then
     Dim R As Hyperlink
     For Each R In ActiveSheet.Hyperlinks
         If R.TextToDisplay > "" Then R.Delete
     Next
   With ActiveSheet
       .Hyperlinks.Add Anchor:=Target, Address:=Target, SubAddress:="", TextToDisplay:=CStr(Target.Text)
   End With
   Set R = Nothing
  End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect(Target, ActiveSheet.UsedRange) Is Nothing Then
     Dim R As Hyperlink
     For Each R In ActiveSheet.Hyperlinks
         If R.TextToDisplay > "" Then R.Delete
     Next
   With ActiveSheet
       .Hyperlinks.Add Anchor:=Target, Address:=Target, SubAddress:="", TextToDisplay:=CStr(Target.Text)
   End With
   Set R = Nothing
 End If
End Sub

 

[ياسر خليل أبو البراء]

جزيت خيراً أخي الغالي أبو نصار

ممكن ملف مرفق لتطبيق الكود لتكتمل الصورة أكثر ..حيث أنني ليس لدي خبرة في التعامل مع الارتباطات التشعبية ..هل الارتبط سيكون مرتبط بالنص المكتوب في الخلية أم بعنوان موقع أم أنه مجرد ارتباط ليس له ارتباط؟؟؟

تقبل وافر تقديري واحترامي

[الـعيدروس]

اخي الكريم ياسر خليل

 الفائده من استخدام الكود بالطريقه التي سردتها بالمشاركه السابقه

   ان لاتحمل كاهل الملف بالهيبرلينك حتى يصبح بطيئ جدا عند الفتح

      وان ولايوقف عند الخليه 650000 كحد اعلى للهيبرلينك فقط بل ينفذ الكود

     حتى يصل عند التوليف "ZZZZ" كأنه كتب عنوان على الخلايا فقط

     ونستخدم العنوان كهيبر لينك عند النقر عليه 

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

     بإضافة بسيطه هذه اضافه لااحبذها الافضل التعامل مع كل خليه كي لا يكبر حجم الملف

           ويصبح بطيئ

        هذا المرفق وبه الكود لحدث الصفحه وكود انشاء العناوين 

   

  

 If ActiveSheet.Hyperlinks.Count >= 65530 Then
      For Each R In ActiveSheet.Hyperlinks
         If R.TextToDisplay > "" Then R.Delete: Exit For
      Next
     End If

 

شرح كود الهايبر لنك_111.rar

[ياسر خليل أبو البراء]

أخي الحبيب أبو نصار

الآن اتضحت الفكرة بالنسبة لي بشكل كامل إن شاء الله وفهمت ما قمت به ..

بارك الله فيك وجزاك الله خير الجزاء على هذه الفكرة الرائعة

تقبل وافر تقديري واحترامي

 

[محمد الزريعي]

بارك الله فيكم جميعاً ..  ولكم خالص الشكر والتقدير  .