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

[Otman Zaki]

اسعد الله اوقاتكم اخواني الاعزاء 

منذ سنوات وانا استخدم هاد القالب خاص بالدوريات ولاكن اجد صعوبة وضع شعار الفرق في الترتيب 

كما تعلمون في الترتيب يتغير تلقائي بمجرد تغير النتائج ولاكن الشعار لابد اضعه يدوي في كل  مرة 

سؤال هل توجد طريقة كيف اربط به اسم الفريق بالشعار ويصبح الشعار ينتقل مع الاسم تلقائي اليكم ملف الذي اعمل عليه 

 

انا مبتدئ على الاكسيل ارجو منكم الشرح مفصل 

 

تجريبة.xlsx

[محمد هشام.]

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

يمكنك إضافة قاعدة بيانات لأسماء الفرق والشعارات الخاصة بها في ورقة جديدة وتسميتها مثلا Logos 

واستخدام الكود التالي في حدث ورقة GroupA لتغيير الشعار تلقائيا بناء على التغيير  في النتيجة 

عندما يتم نقل إسم الفريق في الورقة (أي تغيير موضع الخلية) سيتحرك الشعار إلى الموقع الجديد بشكل تلقائي كما في الصورة أدناه 

 

Option Explicit
Private Sub Worksheet_Calculate()
    Dim tmp As Range, n As Shape, OnRng As Range
    Dim crWS As Worksheet: Set crWS = Me
    Dim dest As Worksheet: Set dest = Sheets("Logos")
    
    Application.ScreenUpdating = False
    For Each tmp In crWS.Range("J14:J" & crWS.Cells(crWS.Rows.Count, "J").End(xlUp).Row)
        If tmp.Value <> "" Then
            For Each n In crWS.Shapes
                If n.Type <> 8 And n.TopLeftCell.Address = tmp.Offset(0, -1).Address Then n.Delete
            Next n
            
        Set OnRng = dest.Range("A2:A" & dest.Cells(dest.Rows.Count, _
                    "A").End(xlUp).Row).Find(tmp.Value, LookAt:=xlWhole)
        
        If Not OnRng Is Nothing Then
            For Each n In dest.Shapes
                If n.TopLeftCell.Address = dest.Cells(OnRng.Row, _
                dest.Range("A2:A" & dest.Cells(dest.Rows.Count, "A").End(xlUp).Row).Column + 1).Address Then
                    n.Copy
                    tmp.Offset(0, -1).Select
                    ActiveSheet.Paste
                    With Selection.ShapeRange
                        .LockAspectRatio = msoFalse
                        .Left = tmp.Offset(0, -1).Left + 4: .Top = tmp.Offset(0, -1).Top + 5
                        .Width = tmp.Offset(0, -1).Width - 8: .Height = tmp.Offset(0, -1).Height - 6
                    End With
                    Selection.ShapeRange(1).Select
                    Selection.ShapeRange(1).TopLeftCell.Select
                End If
            Next n
            Else
                For Each n In crWS.Shapes
                    If n.Type <> 8 And n.TopLeftCell.Address = tmp.Offset(0, -1).Address Then n.Delete
                Next n
            End If
        End If
    Next tmp

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

 

تجريبة v2.xlsb

تم تعديل فبراير 16 بواسطه محمد هشام.