أحتاج تغيير نطاق هذا الكود

[aram]

السلام عليكم اساتذتي الافاضل 

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

 

Sub AddHypaerlinks()
    
    Dim lastRow As Long
    Dim myPath As String, fileName As String
    
    
    myPath = "C:\Users\civat\Desktop\New folder\" 'SET TO WHERE THE FILES ARE LOCATED
    lastRow = Range("B" & Rows.Count).End(xlUp).Row
    
    For i = 2 To lastRow
        
        If Len(Range("B" & i)) > 0 Then
            fileName = myPath & Range("B" & i).Value & "*.docx"
            'IF THE FILE EXISTS THEN
            If Len(Dir(fileName)) <> 0 Then ActiveSheet.Hyperlinks.Add Range("B" & i), myPath & Dir(fileName)
        End If
    Next
    
End Sub

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

 

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

عليكم السلام 

جرب استخدام هذا الكود بعد تحديد الخلايا التي يراد وضع ارتباط تشعبي لها

Sub AddHypaerlinks()
    Dim cl As Range
    Dim myPath As String, fileName As String
    
    myPath = "C:\Users\civat\Desktop\New folder\" 'SET TO WHERE THE FILES ARE LOCATED
    
    For Each cl In Selection
        If Len(cl) > 0 Then
            fileName = myPath & cl.Value & "*.docx"
            'IF THE FILE EXISTS THEN
            If Len(Dir(fileName)) <> 0 Then ActiveSheet.Hyperlinks.Add cl, myPath & Dir(fileName)
        End If
    Next
End Sub

بالتوفيق

[aram]

تمام استاذ شكرا بارك الله فيك