ابراهيم الحداد

السلام عليكم ورحمة الله استخدم الكودين الاتيين الكود الاول لرسم الدوائر Sub Crl_Shp() ' دوائر مواد الرسوب Dim C As Range Dim MyRng As Range Dim LR As Long, i As Long, j As Long Application.ScreenUpdating = False LR = Range("B" & Rows.Count).End(xlUp).Row i = 10 Do While i <= LR Set MyRng = Range(Cells(i, 5), Cells(i, 23)) For Each C In MyRng If C.Value < Cells(9, C.Column).Value Or C.Value = "غ" Or C.Value = "" Then Set x = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left, C.Top, C.Width, C.Height) x.Fill.Visible = msoFalse x.Line.ForeColor.SchemeColor = 10 x.Line.Weight = 1.75 End If Next i = i + 1 Loop Application.ScreenUpdating = True End Sub الكود الثانى لمسح الدوائر عند اللزوم Sub RemovShp() ' مسح الدوائر Dim Shp As Shape For Each Shp In ActiveSheet.Shapes If Shp.AutoShapeType = msoShapeOval Then Shp.Delete Next Shp End Sub

السلام عليكم ورحمة الله ضع هذا الكود فى حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row < 9 Or Target.Column <> 4 Then Exit Sub Call Cases End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub Cases() Dim j As Integer j = 9 Do While Cells(j, "D") <> "" If Cells(j, "D") = "حضور" Then Cells(j, "K") = 100 ElseIf Cells(j, "D") = "غياب" Then Cells(j, "K") = "غياب" ElseIf Cells(j, "D") = "اجازة" Then Cells(j, "K") = "اجازة" Else Cells(j, "K") = "" End If j = j + 1 Loop End Sub

السلام عليكم ورحمة الله غير هذا السطر Range("e22").Value = C.Offset(0, -1) الى sheet2.Range("e22").Value = C.Offset(0, -1)

السلام عليكم ورحمة الله لعل هذا ما تقصده Book1.rar

السلام عليكم ورحمة الله جرب هذا الملف اختبار.xls

السلام عليكم ورحمة الله استخدم هذا الكود Sub DataDate() Dim ws As Worksheet, C As Range Dim LR As Long, i As Integer, x As Integer Dim Dt Set ws = Sheets("ADD") LR = ws.Range("B" & Rows.Count).End(xlUp).Row Dt = ws.Range("S2") For Each C In ws.Range("E2:P2") If C.Value = ws.Range("R2") Then x = C.Column End If Next i = 3 Do While i <= LR If ws.Cells(i, "C") <= Dt And ws.Cells(i, "D") >= Dt Then ws.Cells(i, "R") = ws.Cells(i, x) End If i = i + 1 Loop End Sub

السلام عليكم و رحمة الله اجعل الكود هكذا Private Sub TextBox1_Change() Dim LastRow As Long LastRow = Range("B1000").End(xlUp).Row If ActiveSheet.TextBox1.Text <> "" Then Range("$A$2:$C$" & LastRow).AutoFilter field:=1, Criteria1:=TextBox1.Value End If End Sub

السلام عليكم ورحمة الله جرب هذا Book1.xlsm

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

السلام عليكم ورحمة الله استبدل الكود السابق بهذا الكود Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 3 Or Target.Row < 4 Or Target.Value <> "حلب" Then Exit Sub Msg = MsgBox("هل تريد الاستمرار ؟", vbYesNo) If Msg = vbYes Then Exit Sub Else C.ClearContents End If End Sub

السلام عليكم و رحمة الله اكتب هذه المعادلة فى الخلية ("N2") بشرط الا تترك خلية فارغة فى العمود "L" بدءا من الصف الرابع =OFFSET($L$4;COUNTA($L:$L)-2;0)

السلام عليكم ورحمة الله ضع هذا الكود فى حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 3 Or Target.Row < 4 Then Exit Sub Dim C As Range, CList As Range Dim Msg As String Set CList = Range("C4:C" & Range("A" & Rows.Count).End(xlUp).Row) For Each C In CList If C.Value = "حلب" Then Msg = MsgBox("هل تريد الاستمرار ؟", vbYesNo) If Msg = vbYes Then Exit Sub Else C.ClearContents End If End If Next End Sub

السلام عليكم ورحمة الله بفرض ان تاريخ بداية العمل فى للخلية ("A1") اكتب فى الخلية التى يراد اظهار النتيجة فيها هذه المعادلة : =DATEDIF(A1;TODAY();"y")

السلام عليكم ورحمة الله ضع الكود فى موديول عادى و خصص له زر فى الشيت الذى تريده حتى لو كانت اكتر من شيت فلكل شيت زر مخصص له

السلام عليكم ورحمة الله جرب هذا الملف الرقم القومى2.xlsm

السلام عليكم ورحمة الله بارك الله فيكم احبتى و شكرا على مروركم العطر و الحمد لله على تمام الامر

السلام عليكم ورحمة الله تفضل تكت التليفون والعنوان.xls

السلام عليكم ورحمة اله استخدم هذا الكود Sub DelRows() Dim x As Integer, i As Long, y As Long y = Sheet1.Range("A" & Rows.Count).End(xlUp).Row For i = y To 2 Step -1 x = WorksheetFunction.Days360(Cells(i, "A"), Date) If x < 45 Then Cells(i, "A").EntireRow.Delete End If Next End Sub

السلام عليكم ورحمة الله شكرا لك اخى الكريم على لدعمك المستمر و الله ولى التوفيق

السلام عليكم و رحمة الله بناءا على طلب بعض الاخوة الاعضاء الى اخوانى مسئولى كنترول التعليم الثانوى التجارى اليكم شيت كنترول الصف الثانى مرفق ملف الشيت و معه ملف وورد لشرح طلريقة الاستخدام و انا مستعد لأى استفسار ثانية تجارى.rar

السلام عليكم ورحمة الله استخدم الاكواد الآتية و الغى كل الاكواد الموجودة لديك Private Sub UserForm_Activate() Dim C As Range, Coll As New Collection On Error Resume Next For Each C In Sheets("sheet1").[A2:A5000] Coll.Add C.Value, C.Value Next C On Error GoTo 0 For Each Item In Coll Me.ComboBox1.AddItem Item Next Item End Sub Private Sub ComboBox2_Change() ComboBox3.Clear Dim C As Range For Each C In Sheets("sheet1").[B2:B5000] If Me.ComboBox2.Value <> "" Then If Me.ComboBox2.Value = C.Value And C.Count = 1 Then s = s + 1 ReDim temp(s, 1) temp(s, 1) = C.Offset(0, 1) Me.ComboBox3.AddItem temp(s, 1) End If End If Next End Sub Private Sub ComboBox1_Change() ComboBox2.Clear Dim C As Range For Each C In Sheets("sheet1").[A2:A5000] If Me.ComboBox1.Value <> "" Then If Me.ComboBox1.Value = C.Value Then p = p + 1 ReDim arr(p, 1) arr(p, 1) = C.Offset(0, 1) Me.ComboBox2.AddItem arr(p, 1) End If End If Next End Sub

السلام عليكم ورحمة الله استخدم هذا الكود بديلا للكود الموجود داخل الفورم Private Sub UserForm_Activate() Dim c As Range, Coll As New Collection On Error Resume Next For Each c In Sheets("sheet1").[A2:A5000] Coll.Add c.Value, c.Value Next c On Error GoTo 0 For Each Item In Coll Me.ComboBox1.AddItem Item Next Item If Me.ComboBox1.Value <> "" Then p = p + 1 ReDim arr(p, 1) arr(p, 1) = c.Offset(0, 1) Me.ComboBox2.AddItem arr(p, 1) End If If Me.ComboBox2.Value <> "" Then s = s + 1 ReDim temp(s, 1) temp(s, 1) = c.Offset(0, 2) Me.ComboBox2.AddItem temp(s, 1) End If End Sub

السلام عليكم ورحمة الله ضع هذا الكود فى حدث الصفحة Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column <> 3 Or Target.Row < 7 Then Exit Sub Dim C As Range For Each C In Range("C7:C" & Range("C" & Rows.Count).End(xlUp).Row) If C.Value = "سدد" Then C.Offset(0, 1).Resize(1, 12).Value = "0" C.Offset(0, 13).Resize(1, 3).Value = "لا" End If Next End Sub

السلام عليكم ورحمة الله اخى الكريم جارى العمل على كنترول الصف الثانى و سيكون هناك تغيير جذرى فى بعض الاوراق و شكل جديد سيعجب الجميع ان شاء الله ولكنى احتاج الى مزيد من الوقت