أكاديمية الصقر للتدريب
موضوع بعنوان :تمييز الخلية النشطة بأكثر من طريقة
الكاتب :Yasser Elaraby


بسم الله الرحمن الرحيم

اليوم نقدم لكم طريقة تمييز الخلية النشطة بأكثر من طريقة
المثال الاول
تكبير حجم الخط للخلية النشطة

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    FontSize = ActiveCell.Font.Size
    LargeSize = FontSize * 3
    Cells.Font.Size = FontSize
    ActiveCell.Font.Size = LargeSize
End Sub


المثال الثاني
عمل صورة مكبرة من الخلية المحددة
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'حدد الزوم او عدد تكبير الخلية
    ZoomCell 2
End Sub
Private Sub ZoomCell(ZoomIn As Single)
    Dim s As Range
    Set s = Selection
    'Get rid of any existing zoom pictures
    For Each p In ActiveSheet.Pictures
        If p.Name = "ZoomCell" Then
            p.Delete
            Exit For
        End If
    Next
    'Create a zoom picture
    s.CopyPicture Appearance:=xlScreen, _
      Format:=xlPicture
    ActiveSheet.Pictures.Paste.Select
    With Selection
        .Name = "ZoomCell"
        With .ShapeRange
            .ScaleWidth ZoomIn, msoFalse, _
              msoScaleFromTopLeft
            .ScaleHeight ZoomIn, msoFalse, _
              msoScaleFromTopLeft
            With .Fill
                .ForeColor.SchemeColor = 9
                .Visible = msoTrue
                .Solid
            End With
        End With
    End With
    s.Select
    Set s = Nothing
End Sub

المثال الثالث
تغيير لون الخلية النشطة ولكن يجعل الخلايا كلها بدون لون اي نستخدمه في حالة عدم تلوين اي خلية داخل الشيت
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.ScreenUpdating = False
    Cells.Interior.ColorIndex = 0
    Target.Interior.ColorIndex = 3
    Application.ScreenUpdating = True
End Sub



المثال الرابع
تغيير لون الخلية النشطة مع الحفاظ على الوان الخلايا الموجودة الملونة  مسبقا
Private objCurrentCell As Range
Private OrigColorIdx As Long
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.EnableEvents = False
    On Error Resume Next
    If objCurrentCell Is Nothing Then
        Set objCurrentCell = Target
        OrigColorIdx = Target.Interior.ColorIndex
        Target.Interior.ColorIndex = 3
    Else
        objCurrentCell.Interior.ColorIndex = OrigColorIdx
        Set objCurrentCell = Target
        OrigColorIdx = Target.Interior.ColorIndex
        Target.Interior.ColorIndex = 3
    End If
    Application.EnableEvents = True
End Sub


تحياتي