اذهب الي المحتوي
أوفيسنا

تعديل كود عمل دائرة


الردود الموصى بها

 

الاساتذة الكرام 

ارفق لكم ملف اتنمى منكم المساعده فيه المطلوب 

في الملف يوجد زر عند الضغط عليه يقوم بعمل دائره في الخليه المختاره 

1- المطلوب بدل الضغط على الزر النقر بالمواس مرتين يعني عند اختيار التاريخ نقوم بالضغط على المؤس مرتيين يتم عمل الدائره على الخليه 

2- في المربع الاصف يقوم بجمع عدد الدوائر 

3- تغيير لون الدائره الى اللون الاحمر 

 

شاكر لكم تعاونكم ولكم مني ارقى تحيه 

Dynamic Calendar.xlsm

رابط هذا التعليق
شارك

In worksheet module put the code

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim rng As Range
    Set rng = Range("F9:L13")
    If Not Intersect(Target, rng) Is Nothing Then
        Cancel = True
        Call VBA_Circle_Text
        Range("K17").Value = CountOvalShapes(rng)
    End If
End Sub

Sub VBA_Circle_Text()
    Dim cel As Range, m As Double, n As Double
    Set cel = Application.Selection
    DeleteShapesWithinRange cel
    With cel
        m = .Height * 0.1
        n = .Width * 0.1
        Application.ActiveSheet.Ovals.Add Top:=.Top - m, Left:=.Left - n, Height:=.Height + 2.25 * m, Width:=.Width + 1.75 * n
        With Application.ActiveSheet.Ovals(ActiveSheet.Ovals.Count)
            .Interior.ColorIndex = xlNone
            With .ShapeRange.Line
                .Weight = 2
                .ForeColor.RGB = vbRed
            End With
        End With
    End With
    cel.Select
End Sub

Function CountOvalShapes(ByVal rng As Range) As Long
    Dim shp As Shape, cnt As Long
    For Each shp In ActiveSheet.Shapes
        If shp.Type = 1 And Not Intersect(shp.TopLeftCell.MergeArea, rng) Is Nothing Then cnt = cnt + 1
    Next shp
    CountOvalShapes = cnt
End Function

Sub DeleteShapesWithinRange(ByVal rng As Range)
    Dim shp As Shape
    For Each shp In rng.Parent.Shapes
        If Not Application.Intersect(rng.Parent.Range(shp.TopLeftCell.Offset(1, 1).Address), rng) Is Nothing Then shp.Delete
    Next shp
End Sub

 

  • Like 3
  • Thanks 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information