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
تم الحل شكرا خااااااااااااااااالص