طلب تعديل على كود ترقيم بحيث لا يتأثر بالفلترة

[Alaa Ammar New]

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

أساتذتي الكرام جدا @محمد هشام. 

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

أنا آسف وهناك سؤال آخر إذا تكرمت

أنا أنسخ رابط من الفيس او اليوتيوب في خاناتهم واكتب كلمة رابط الفيس أو رابط اليوتيوب واعملها هايبرلينك وانسخ داخلهما الرابط وبعد كدة أعيد تنسيقهم بإذالة الخط الأسبل والتكبير وتغيير اللون والحجم

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

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

14-7-2024.xlsm

تم تعديل يوليو 16 بواسطه Alaa Ammar New

[محمد هشام.]

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

=IF(C9>0,SUBTOTAL(3,$C$9:C9),"")

اما بخصوص  تنسيق اعمدة الروابط اظن انه من الافضل ربط الكود مع زر يمكنك استخدامه مثلا بعد الانتهاء من نسخ جميع الروابط على العمودين 

جرب هدا

Function tmp(Cnt As String) As Boolean
    Dim Request As Object
    Dim rc As Variant
    On Error GoTo EndNow
    Set Request = CreateObject("WinHttp.WinHttpRequest.5.1")
    With Request
      .Open "GET", Cnt, False
      .Send
      rc = .StatusText
    End With
    Set Request = Nothing
    If rc = "OK" Then tmp = True
    Exit Function
EndNow:
End Function

 

Sub add_Hyperlinks()

Application.ScreenUpdating = False
Set WS = Sheets("Sheet1")
Dim c As Excel.Range, Cnt As String, r As Excel.Range
Dim a As Range, b As Range, Rng As Range

    lr = WS.Columns("i:j").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
          Set a = WS.Range("i9:i" & lr): Set b = WS.Range("j9:j" & lr): Set Rng = Union(a, b)
For Each c In a
   If c > "" Then
    c.Select
    Debug.Print c.Value
    Cnt = Trim(CStr(c.Text))
    If Left(Cnt, 4) <> "http" Then Cnt = "http://" & Cnt
    If tmp(Cnt) Then WS.Hyperlinks.Add Anchor:=c, Address:=Cnt, TextToDisplay:="رابط اليوتيوب"
    End If
 Next c
For Each r In b
   If r > "" Then
    r.Select
    Debug.Print r.Value
    Cnt = Trim(CStr(r.Text))
    If Left(Cnt, 4) <> "http" Then Cnt = "http://" & Cnt
    If tmp(Cnt) Then WS.Hyperlinks.Add Anchor:=r, Address:=Cnt, TextToDisplay:="رابط الفيسبوك"
    End If
 Next r
With Rng
        .Font.Color = RGB(0, 0, 255)
        .Font.Underline = xlUnderlineStyleNone
        .Font.Bold = True
        .Font.Name = "Calibri"
        .Font.Size = 16
  End With
  Application.ScreenUpdating = True
End Sub

 

14-7-2024 V2.xlsm

[Alaa Ammar New]

الشكر الجزيل لك أستاذي القدير المحترم مهما فعلت لن أوفيك حقك في الشكر

جزاك الله خير الجزاء وحفظك وأسرتك من كل سوء