اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

كود داوئر

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

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

  • أفضل إجابة
محمد هشام.

محمد هشام.

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

تفضل اخي  

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