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

[موضوع مميز]شرح عمل شيت كنترول ( درة أعمال العلامة عبد الله باقشير)[مثبت]


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

من باب ان يتم تجميع الاعمال القيمه للمعلمين في هذا الموضوع اضيف

 

المرجع الاول في دوال البحث مع الشرح المفصل

استدعاء بيانات الشهادات بمعية رقم الجلوس مع الشرح المفصل

للعملاق ياسر خليل

بيانات الشهادات بمعية رقم الجلوس مع الشرح.rar

  • Like 1
رابط هذا التعليق
شارك

كود اضافة الدوائر الحمرا ويعمل بطريقة فريده

يمكنك استخدام تكبير او تصغير العرض بدون التاثير في وضع الدوائر في اماكنها (سيعمل الكود بدون مشاكل)
ActiveWindow.Zoom

 

صف الدرجات  متغير هنا  الصف رقم 12
اذا كانت الخلية في هذا الصف ليست رقم  .. لا تتم اضافة دائرة في صفوف عمود الخلية

 

عمود رقم الجلوس العمود متغير هنا رقم 2
اذا كان هذا العمود فاضي او صفر لن تتم اضافة الدوائر

 

تم عمل زر مزدوج لإضافة وحذف الدوائر باسم (الدائرة)

Sub اضافة_حذف()
On Error Resume Next
Dim XX As Shape
Set XX = ورقة3.Shapes("الدائرة")
With XX.TextFrame.Characters
    If .Text = "اضافة الدوائر" Then
       Circles1
       .Text = "حذف الدوائر"
    Else
       RemoveCircles1
       .Text = "اضافة الدوائر"
    End If
End With
On Error GoTo 0
End Sub
Sub Circles1()
Dim C As Range
Dim MyRng As Range
Dim V As Shape
Dim X As Integer
Dim G As Integer, R As Integer
'================================================
'    عمود رقم الجلوس
G = 2
'    صف الدرجات
R = 12
' نطاق الخلايا الذي تريد اضافة الدوائر فيها
Set MyRng = Range("N13:BQ47")
'=================================================
' اذا كانت النطاقات مختلفة يمكنك الاشارة اليهم بالتالي
'Set MyRng = Range("O13:O47,Q13:Q47,S13:S47")
'=================================================
X = ActiveWindow.Zoom
Application.ScreenUpdating = False
ActiveWindow.Zoom = 100
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 1
    If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) Or C.Value = "غ" Or C.Value = "غـ") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 1, C.Top + 1, C.Width - 2, C.Height - 2)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.25
    End If
1 Next
ActiveWindow.Zoom = X
Application.ScreenUpdating = True
End Sub
Sub RemoveCircles1()
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
      If shp.AutoShapeType = msoShapeOval Then shp.Delete
    Next shp
End Sub

دعوة طيبه لوحه الله لكل من ساهم في هذا العمل

اضافة و حذف دوائر_2.rar

  • Like 1
رابط هذا التعليق
شارك

Option Explicit
Sub SortTable()

  'code written by Dave Peterson 2005-10-22
  Dim myTable As Range
  Dim myColToSort As Long
  Dim curWks As Worksheet
  Dim mySortOrder As Long
  Dim LastRow As Long
  Dim iCol As Integer
  Dim strCol As String
  iCol = 20  '10 columns
  strCol = "b"  ' column to check for last row

  Set curWks = ActiveSheet
  With curWks
    myColToSort = .Shapes(Application.Caller).TopLeftCell.Column
    LastRow = .Cells(.Rows.Count, strCol).End(xlUp).Row
    Set myTable = .Range("a6:a" & LastRow).Resize(, iCol)
    If .Cells(myTable.Row + 1, myColToSort).Value _
      < .Cells(LastRow, myColToSort).Value Then
        mySortOrder = xlDescending
    Else
        mySortOrder = xlAscending
    End If
    myTable.Sort key1:=.Cells(myTable.Row, myColToSort), _
              order1:=mySortOrder, _
              header:=xlYes
  End With

End Sub




كود المرفق السابق

رابط هذا التعليق
شارك

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

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

Important Information