أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
محمدعبدالسلام لا تميز خلال هذه الفترة-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة طلب مساعدة اريد في كل 4 من شهر يتم نسح الاسم من عمود الى عمود اكسيل اسئله واجابات


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





وضع الشرطه المائله بشرط

السلام عليكم ورحمة الله وبركاته معي ملف حاولت فيه الكثير التعديل على الكود الموجود وذاك آخر ما توصلت اليه رجاء المساعده ..


موضوع مغلق


23-10-2020 11:01 مساء
نصر الإيمان
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 446
الجنس : ذكر
تاريخ الميلاد : 29-12-1985
يتابعهم : 8
يتابعونه : 4
قوة السمعة : 885
 offline 

السلام عليكم ورحمة الله وبركاته
معي ملف حاولت فيه الكثير التعديل على الكود الموجود وذاك آخر ما توصلت اليه رجاء المساعده ؟؟؟؟؟
اريد وضع شرطه مائله على الدرجه والتقدير ...وذلك اذا تم رفعها لدرجه اعلى ذات اللون الأحمر
وجزاكم الله خيرا
 
MzczOTY0MQ3232Untitled
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
  DATA.xlsm   تحميل xlsm مرات التحميل :(8)
الحجم :(39.241) KB



أفضل إجابة مقدمة من salim وهي:
تم التعديل

Option Explicit
'+++++++++++++++++++++++++++++++++++
Sub DeleteShapes()
Dim L, T, W, H
L = 980: T = 10: W = 210: H = 66
If ActiveSheet.Shapes.Count > 0 Then
ActiveSheet.Shapes.SelectAll
Selection.Delete
End If
'+++++++++++++++++++++++++++

ActiveSheet.Buttons.Add(L, T, W, H).Select
  With Selection
   .OnAction = "SLASHH_Total"
   .Characters.Text = "Run"
    With .Characters(1, 3).Font
     .Size = 36
     .ColorIndex = 3
     .Bold = True
    End With
  End With
  End Sub

'+++++++++++++++++++++++++++
Sub DrawSlash(headerRange As Range, DataRange As Range)
 
    Dim shp         As Shape
    Dim c           As Range
    Const d         As Byte = 15

  For Each c In headerRange
      If Application. _
      CountA(DataRange.Columns(c.Column - DataRange.Column + 1)) > 0 Then
         With ActiveSheet.Shapes _
          .AddLine(c.Left + d, c.Top + d, _
           c.Left + c.Width - d, c.Top + c.Height * 2 - d).Line
           .ForeColor.RGB = vbRed
          .Weight = 5
        End With
      End If
  Next c
End Sub
'+++++++++++++++++++++++++++++++++++++++++++
Sub SLASHH_Total()
    Dim ws          As Worksheet
    Dim m           As Long
    Dim i           As Long
  DeleteShapes
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("sheet_mostgad")
        m = ws.Cells(Rows.Count, "C").End(xlUp).Row + 3
     
  For i = 5 To m Step 4
    If ws.Range("AY" & i + 2).Font.ColorIndex = 3 And _
       ws.Range("AY" & i + 2) <> "" Then
       DrawSlash ws.Range("AY" & i + 1), ws.Range("AY" & i + 2)
    End If
   Next i
    Application.ScreenUpdating = True
End Sub

 
عرض الإجابة




24-10-2020 12:02 صباحا
مشاهدة مشاركة منفردة [1]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif وضع الشرطه المائله بشرط
Try This macro

Option Explicit
Sub DeleteTextBoxes()
Dim L, T, W, H
L = 980: T = 10: W = 210: H = 66
If ActiveSheet.Shapes.Count > 0 Then
ActiveSheet.Shapes.SelectAll
Selection.Delete
End If
'+++++++++++++++++++++++++++

ActiveSheet.Buttons.Add(L, T, W, H).Select
  With Selection
   .OnAction = "SLASHH_Total"
   .Characters.Text = "Run"
    With .Characters(1, 3).Font
     .Size = 36
     .ColorIndex = 3
     .Bold = True
    End With
  End With
  End Sub

'+++++++++++++++++++++++++++
Sub DrawSlash(headerRange As Range, DataRange As Range)
 
    Dim shp         As Shape
    Dim c           As Range
    Const d         As Integer = 15

  For Each c In headerRange
      If Application. _
      CountA(DataRange.Columns(c.Column - DataRange.Column + 1)) > 0 Then
        With ActiveSheet.Shapes _
          .AddLine(c.Left + d, c.Top + d, _
           c.Left + c.Width - d, c.Top + c.Height - d).Line
          .ForeColor.RGB = RGB(255, 0, 0)
          .Weight = 4.55
        End With
      End If
  Next c
End Sub
'+++++++++++++++++++++++++++++++++++++++++++
Sub SLASHH_Total()
    Dim ws          As Worksheet
    Dim oRng        As Range
    Dim m           As Long
    Dim i           As Long
  DeleteTextBoxes
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("sheet_mostgad")
        m = ws.Cells(Rows.Count, "C").End(xlUp).Row + 3
     
  For i = 5 To m Step 4
    DrawSlash ws.Range("AY" & i & ":AY" & i), _
    ws.Range("AY" & i + 1 & ":AY" & i + 2)
   Next i
    
   If Not oRng Is Nothing Then _
    oRng.Interior.Color = RGB(208, 206, 206)
    Application.ScreenUpdating = True
End Sub

 

24-10-2020 01:26 صباحا
مشاهدة مشاركة منفردة [2]
نصر الإيمان
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 446
الجنس : ذكر
تاريخ الميلاد : 29-12-1985
يتابعهم : 8
يتابعونه : 4
قوة السمعة : 885
 offline 
look/images/icons/i1.gif وضع الشرطه المائله بشرط
عند تشغيل الكود يتم تظليل كافة الخلايا للطلاب ا.....  اريد فقط التي تم رفعها اي التي درجاتها باللون الاحمر
MTYyMTM5MQ93932727
 
 


24-10-2020 07:21 صباحا
مشاهدة مشاركة منفردة [3]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif وضع الشرطه المائله بشرط
تم التعديل

Option Explicit
'+++++++++++++++++++++++++++++++++++
Sub DeleteShapes()
Dim L, T, W, H
L = 980: T = 10: W = 210: H = 66
If ActiveSheet.Shapes.Count > 0 Then
ActiveSheet.Shapes.SelectAll
Selection.Delete
End If
'+++++++++++++++++++++++++++

ActiveSheet.Buttons.Add(L, T, W, H).Select
  With Selection
   .OnAction = "SLASHH_Total"
   .Characters.Text = "Run"
    With .Characters(1, 3).Font
     .Size = 36
     .ColorIndex = 3
     .Bold = True
    End With
  End With
  End Sub

'+++++++++++++++++++++++++++
Sub DrawSlash(headerRange As Range, DataRange As Range)
 
    Dim shp         As Shape
    Dim c           As Range
    Const d         As Byte = 15

  For Each c In headerRange
      If Application. _
      CountA(DataRange.Columns(c.Column - DataRange.Column + 1)) > 0 Then
         With ActiveSheet.Shapes _
          .AddLine(c.Left + d, c.Top + d, _
           c.Left + c.Width - d, c.Top + c.Height * 2 - d).Line
           .ForeColor.RGB = vbRed
          .Weight = 5
        End With
      End If
  Next c
End Sub
'+++++++++++++++++++++++++++++++++++++++++++
Sub SLASHH_Total()
    Dim ws          As Worksheet
    Dim m           As Long
    Dim i           As Long
  DeleteShapes
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("sheet_mostgad")
        m = ws.Cells(Rows.Count, "C").End(xlUp).Row + 3
     
  For i = 5 To m Step 4
    If ws.Range("AY" & i + 2).Font.ColorIndex = 3 And _
       ws.Range("AY" & i + 2) <> "" Then
       DrawSlash ws.Range("AY" & i + 1), ws.Range("AY" & i + 2)
    End If
   Next i
    Application.ScreenUpdating = True
End Sub

 



الكلمات الدلالية
الشرطه ، المائله ، بشرط ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 05:49 صباحا