كود خط مائل

[Abdelhady Tahoon]

طلب كود لوضع خط مائل على الدرجة اقل من الربع بحيث يكون الخط مائل وليس اسفل الرقم

[الـعيدروس]

السلام عليكم

Sub A_qtr()
Dim الربع%, الدرجة%
Dim Rn As Range
''***************
' حط قيمة الدرجة
الدرجة = 100
For Each Rn In [A2:A1000] ' المدى المراد تطبيق الكود عليه
  If Val(Rn) < (الدرجة / 4) Then Rn.Font.Italic = True
Next
End Sub

[Abdelhady Tahoon]

اخى الكريم عياد شكراً على اهتمامك  (لقد نفذت الخطوات التى قلت عليها ولم يحدث اى شى سوى تغير نوع الخط )

[الـعيدروس]

السلام عليكم

 

جرب الكود التالي 

علي فهمت ماتريد

Private Const Sm As String = "$A$2:$A$1000"
Sub A_qtr()
Dim الربع%, الدرجة%
Dim Rn As Range, Sn As Shape
''***************
' حط قيمة الدرجة
الدرجة = 100
On Error Resume Next
D_Shp
For Each Rn In Range(Sm) ' المدى المراد تطبيق الكود عليه
 With Rn
  If Val(Rn) < (الدرجة / 4) And Not IsEmpty(Rn) Then
 Set Sn = ActiveSheet.Shapes.AddShape(183, .Left + 4, .Top + 3, .Width / 1.3, .Height - 7)
  With Sn
    .ForeColor.RGB = RGB(255, 0, 0)
    .BackColor.RGB = RGB(0, 170, 170)
  End With
  End If
 End With
Next
End Sub
Private Sub D_Shp()
    Dim Sn As Shape
        For Each Sn In ActiveSheet.Shapes
           Sn.Delete
        Next
End Sub

تم تعديل أغسطس 6, 2013 بواسطه عباد

[عبدالله باقشير]

السلام عليكم

بعد اذن اخي الحبيب ابو انصار

 

وائراءا للموضوع شاهد المرفق 2003

اضافة خظ مائل الى ربع الدرجة.rar

[الـعيدروس]

استاذ عبدالله حفظك الله ورعاك

عمل في قيمة الروعة

بارك الله لك في علمك وزادك اضعافا

 

اسمح لي بااستفسار بسيط 

الجزئيه التاليه من الكود

shp.AutoShapeType

AutoShapeType و type

انا حاولت استخدام type للإشارة الى نوع الشكل

لحذفه فقط في المدى المعني ولم ينفذ الكود كالتالي

Private Sub D_Shp()
Dim Sn As Shape
With ActiveSheet
   For Each Sn In .Shapes
       If Not Intersect(Sn.TopLeftCell, .Range(Sm)) Is Nothing Then
         If Sn.type = 183 Then Sn.Delete
       End If
    Next Sn
End With
End Sub

هل type لاتعمل على 2007

وجزاك الله الف خير على ماتقدمه لنا من علم غزير

[عبدالله باقشير]

السلام عليكم

 

جرب هذا الكود

Sub D_Shp()
Dim Sn As Shape
        For Each Sn In ActiveSheet.Shapes
        If Sn.AutoShapeType = 183 Then Sn.Delete
        Next
End Sub

انا جربته على 2010 يعمل تمام