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

[Al Harthi]

 

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

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

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

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

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

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

 

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

Dynamic Calendar.xlsm

[lionheart]

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

 

[Al Harthi]

 

تسلم اناملك 

لك مني جزيل الشكر والتقدير 

[Al Harthi]

 

تسلم اناملك 

لك مني جزيل الشكر والتقدير بس واجهتني مشكله حين تغيير التاريخ الكود لا يعمل 

[lionheart]

Describe exactly what you did manually and attach the new file

[Al Harthi]

 

ردودك السريعه في محل تقدير استاذي العزيز "lionheart"

بعد اضافة الكود الذي قمت بتعديله جزاك الله الف خير عن فتح الملف وتغيير التاريخ الكود لا يعمل. 

 

Dynamic Calendar.xlsm

[lionheart]

I have downloaded both of your files and both of them don't work when changing the dates

The VBA codes have no problem. The problem is with the file itself

تم تعديل مارس 11, 2023 بواسطه lionheart