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

كود داوئر

خالد المصـــــــــــرى
 مشاركة
إذهب إلى أفضل إجابة Solved by محمد هشام.,

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

خالد المصـــــــــــرى

خالد المصـــــــــــرى

قام بنشر
قام بنشر

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

 

دوائر.xls

رابط هذا التعليق
شارك
  • أفضل إجابة
محمد هشام.

محمد هشام.

قام بنشر
  • أفضل إجابة
قام بنشر

تفضل اخي  

Function circle1(dr As Range)
Dim OvName As String
  OvName = "oval" + dr.AddressLocal
  MrH = 0.3 * dr.Height
 MrW = 0.2 * dr.Width
 OvalW = dr.Width - MrW
 OvalH = dr.Height - MrH
 Set shShape = dr.Worksheet.Shapes.AddShape(msoShapeOval, dr.Left + MrW / 2, dr.Top + MrH / 2, OvalW, OvalH)
 With shShape
 .Name = OvName
 .Fill.Visible = msoTrue
 .Line.Weight = False
 .Fill.ForeColor.RGB = RGB(255, 255, 0)
 End With
End Function

 

دوائر v2.xls

  • Like 2
رابط هذا التعليق
شارك
خالد المصـــــــــــرى

خالد المصـــــــــــرى

قام بنشر
  • الكاتب
قام بنشر

شكرا اخي الكريم ربنا يزيدك

بس لو امكن حدود الدائرة الصفراء تبقى صفر وحدود الدائرة الحمراء تبقى حمرا وحدود الدائرة الخضراء خضرا

رابط هذا التعليق
شارك
خالد المصـــــــــــرى

خالد المصـــــــــــرى

قام بنشر
  • الكاتب
قام بنشر (معدل) 
Function circle5(dr As Range)
Dim OvName As String
  OvName = "ty" + dr.AddressLocal
  MrH = 0.3 * dr.Height
 MrW = 0.2 * dr.Width
 OvalW = dr.Width - MrW
 OvalH = dr.Height - MrH
 Set shShape = dr.Worksheet.Shapes.AddShape(msoShapeOval, dr.Left + MrW / 2, dr.Top + MrH / 2, OvalW, OvalH)
 With shShape
 .Name = OvName
 .Fill.Visible = msoTrue
 .Fill.ForeColor.RGB = RGB(0, 102, 204)
.Fill.Transparency = 0
    End With
End Function
Function circle2(dr As Range)
Dim OvName As String
  OvName = "mh" + dr.AddressLocal
  MrH = 0.3 * dr.Height
 MrW = 0.2 * dr.Width
 OvalW = dr.Width - MrW
 OvalH = dr.Height - MrH
 Set shShape = dr.Worksheet.Shapes.AddShape(msoShapeOval, dr.Left + MrW / 2, dr.Top + MrH / 2, OvalW, OvalH)
 With shShape
 .Name = OvName
 .Fill.Visible = msoTrue
 .Fill.ForeColor.RGB = RGB(255, 0, 0)
.Fill.Transparency = 0
    End With
End Function
Function circle1(dr As Range)
Dim OvName As String
OvName = "st" + dr.AddressLocal
MrH = 0.3 * dr.Height
MrW = 0.2 * dr.Width
OvalW = dr.Width - MrW
OvalH = dr.Height - MrH
Set shShape = dr.Worksheet.Shapes.AddShape(msoShapeOval, dr.Left + MrW / 2, dr.Top + MrH / 2, OvalW, OvalH)
With shShape
 .Name = OvName
 .Fill.Visible = msoTrue
 .Fill.ForeColor.RGB = RGB(255, 255, 0)
.Fill.Transparency = 0
    End With
End Function
Function circle3(dr As Range)
Dim OvName As String
  OvName = "shp" + dr.AddressLocal
  MrH = 0.3 * dr.Height
 MrW = 0.2 * dr.Width
 OvalW = dr.Width - MrW
 OvalH = dr.Height - MrH
 Set shShape = dr.Worksheet.Shapes.AddShape(msoShapeOval, dr.Left + MrW / 2, dr.Top + MrH / 2, OvalW, OvalH)
 With shShape
 .Name = OvName
 .Fill.Visible = msoTrue
 .Fill.ForeColor.RGB = RGB(0, 176, 80)
.Fill.Transparency = 0
    End With
End Function
Sub Select_Shape()
Call رسم_4_الدوائر
Call رسم_5_الدوائر
Call رسم_6_الدوائر
Call رسم_7_الدوائر
 End Sub

Sub رسم_4_الدوائر()

Dim r As Integer
' لغة عربية
Application.ScreenUpdating = False
For r = 5 To 123
If Cells(r, "c") = "ازرق" Then
circle5 Cells(r, "c")
End If
Next r
 r = 0
 ' يات
 For r = 5 To 123
If Cells(r, "d") = "ازرق" Then
circle5 Cells(r, "d")
End If
Next r
 r = 0
  ' لغة انجلة
 For r = 5 To 123
If Cells(r, "e") = "ازرق" Then
circle5 Cells(r, "e")
End If
Next r
 r = 0
  ' ن
 For r = 5 To 123
If Cells(r, "f") = "ازرق" Then
circle5 Cells(r, "f")
End If
Next r
 r = 0
 
   ' ين
 For r = 5 To 123
If Cells(r, "g") = "ازرق" Then
circle5 Cells(r, "g")
End If
Next r
 r = 0
  For r = 5 To 123
If Cells(r, "h") = "ازرق" Then
circle5 Cells(r, "h")
End If
Next r
 r = 0
 ' ديقن
 For r = 5 To 123
If Cells(r, "i") = "ازرق" Then
circle5 Cells(r, "i")
End If
Next r
 r = 0
Dim shp As Shape
For Each shp In Worksheets("رصد").Shapes
    If shp.Name Like "ty*" Then
        shp.Select
        With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 102, 204)
.Transparency = 0
Range("a6").Select
Application.CutCopyMode = False
End With
    End If
Next shp
End Sub
Sub رسم_5_الدوائر()

Dim r As Integer
' لغة عربية
Application.ScreenUpdating = False
For r = 5 To 123
If Cells(r, "c") = "اصفر" Then
 circle1 Cells(r, "c")

End If
Next r
 r = 0
 ' يات
 For r = 5 To 123
If Cells(r, "d") = "اصفر" Then
circle1 Cells(r, "d")
End If
Next r
 r = 0
  ' لغة انجلة
 For r = 5 To 123
If Cells(r, "e") = "اصفر" Then
circle1 Cells(r, "e")
End If
Next r
 r = 0
  ' ن
 For r = 5 To 123
If Cells(r, "f") = "اصفر" Then
circle1 Cells(r, "f")
End If
Next r
 r = 0
 
   ' ين
 For r = 5 To 123
If Cells(r, "g") = "اصفر" Then
circle1 Cells(r, "g")
End If
Next r

 r = 0
   ' عين
 For r = 5 To 123
If Cells(r, "h") = "اصفر" Then
circle1 Cells(r, "h")
End If
Next r
 r = 0
 ' ديقن
 For r = 5 To 123
If Cells(r, "i") = "اصفر" Then
circle1 Cells(r, "i")
End If
Next r
 r = 0
Dim shp As Shape
For Each shp In Worksheets("رصد").Shapes
If shp.Name Like "st*" Then
shp.Select
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 0)
.Transparency = 0
Range("a6").Select
Application.CutCopyMode = False
End With
    End If
Next shp

  End Sub
  
Sub رسم_6_الدوائر()   'احمر
Dim r As Integer
' لغة عربية
Application.ScreenUpdating = False
For r = 5 To 123
If Cells(r, "c") = "احمر" Then
circle2 Cells(r, "c")
End If
Next r
 r = 0
 ' يات
 For r = 5 To 123
If Cells(r, "d") = "احمر" Then
circle2 Cells(r, "d")
End If
Next r
 r = 0
  ' لغة انجلة
 For r = 5 To 123
If Cells(r, "e") = "احمر" Then
circle2 Cells(r, "e")
End If
Next r
 r = 0
  ' ن
 For r = 5 To 123
If Cells(r, "f") = "احمر" Then
circle2 Cells(r, "f")
End If
Next r
 r = 0
 
   ' ين
 For r = 5 To 123
If Cells(r, "g") = "احمر" Then
circle2 Cells(r, "g")
End If
Next r
 r = 0
  For r = 5 To 123
If Cells(r, "h") = "احمر" Then
circle2 Cells(r, "h")
End If
Next r
 r = 0
 ' ديقن
 For r = 5 To 123
If Cells(r, "i") = "احمر" Then
circle2 Cells(r, "i")
End If
Next r
 r = 0
Dim shp As Shape
For Each shp In Worksheets("رصد").Shapes
    If shp.Name Like "mh*" Then
        shp.Select
        With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
Range("a6").Select
Application.CutCopyMode = False
End With
    End If
Next shp
End Sub
Sub رسم_7_الدوائر()   'اخضر
Dim r As Integer
' لغة عربية
Application.ScreenUpdating = False
For r = 5 To 123
If Cells(r, "c") = "اخضر" Then
circle3 Cells(r, "c")
End If
Next r
 r = 0
 ' يات
 For r = 5 To 123
If Cells(r, "d") = "اخضر" Then
circle3 Cells(r, "d")
End If
Next r
 r = 0
  ' لغة انجلة
 For r = 5 To 123
If Cells(r, "e") = "اخضر" Then
circle3 Cells(r, "e")
End If
Next r
 r = 0
  ' ن
 For r = 5 To 123
If Cells(r, "f") = "اخضر" Then
circle3 Cells(r, "f")
End If
Next r
 r = 0
 
   ' ين
 For r = 5 To 123
If Cells(r, "g") = "اخضر" Then
circle3 Cells(r, "g")
End If
Next r
 r = 0
  For r = 5 To 123
If Cells(r, "h") = "اخضر" Then
circle3 Cells(r, "h")
End If
Next r
 r = 0
 ' ديقن
 For r = 5 To 123
If Cells(r, "i") = "اخضر" Then
circle3 Cells(r, "i")
End If
Next r
 r = 0
Dim shp As Shape
For Each shp In Worksheets("رصد").Shapes
    If shp.Name Like "shp*" Then
        shp.Select
        With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 80)
.Transparency = 0
Range("a6").Select
Application.CutCopyMode = False
End With
    End If
Next shp
End Sub

 

تم الحل شكرا خااااااااااااااااالص

تم تعديل بواسطه خالد المصـــــــــــرى
تم الحل شكرا خاااااااااالص
  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك
زائر
هذا الموضوع مغلق.
 مشاركة
الذهاب الي قائمه المواضيع

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

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

Important Information

  I accept