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

السلام عليكم كل عام وانتم بخير .. مبارك عليكم الشهر شاهد المرفق 2010 ترحيل غياب_2.rar

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

السلام عليكم جزاكم الله خيرا و شهر مبارك وكل عام وانتم بخير تقبلوا تحياتي وشكري

السلام عليكم جرب التالي: Private Sub CommandButton1_Click() Me.TextBox4 = CDate(Me.TextBox1) + CDate(Me.TextBox2) + CDate(Me.TextBox3) End Sub

عدد الصفوف في الفورمة حسب اكبر قيمة للتسلسل في النطاق A7:A10 Sub kh_Trheel() Dim ShName As String Dim Lr As Long Dim c As Integer, Cont As Integer ' استخراج رقم الشهرلاستخدامة لاسم الورقة ShName = Month(Range("C1")) ' A7:A10 عدد الصفوف في الفورمة حسب اكبر قيمة للتسلسل في النطاق Cont = WorksheetFunction.Max(Range("A7:A10")) Application.ScreenUpdating = False On Error GoTo 1 With Worksheets(ShName) ' آخر عمود في الصف الاول لورقة الشهر زايدا واحد c = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1 ' نقل التاريخ واسم الكورس وغيره في الصفوف الاربعة الاولى .Cells(1, c).Value = Range("C1").Value .Cells(2, c).Value = Range("K1").Value .Cells(3, c).Value = Range("K2").Value .Cells(4, c).Value = Range("K3").Value ' آخر صف في العمود الاول لورقة الشهر زايدا واحد Lr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 ' نقل التاريخ في الصفوف الاربعة في العمود الاول .Range("A" & Lr).Resize(Cont, 1).Value = Range("C1").Value ' نسخ الجدول Range("B7:L7").Resize(Cont).Copy ' لصق الجدول .Range("B" & Lr).PasteSpecial xlPasteValues End With Application.CutCopyMode = False ' مسح الجدول kh_Clear 1: Application.ScreenUpdating = True End Sub ' كود المسح بدون مسح المعادلات Sub kh_Clear() On Error Resume Next Range("A7:L10").SpecialCells(xlCellTypeConstants).ClearContents Range("K1:K4").ClearContents On Error GoTo 0 End Sub

السلام عليكم جرب المعادلة التالية =IF(AND(SUM(C4:D4)>=24;SUM(B4:D4)>=50);SUM(B4:D4);"--") تحياتي

السلام عليكم بعد اذن اخي ابو حنين شاهد المرفق 2010 store1.rar

تم تعديل اسماء الاوراق برقم الاشهر وليس التسمية وهذا افضل ليعمل الكود في اي جهاز Sub kh_Trheel() Dim ShName As String Dim Lr As Long Dim c As Integer ' استخراج رقم الشهرلاستخدامة لاسم الورقة ShName = Month(Range("C1")) Application.ScreenUpdating = False On Error GoTo 1 With Worksheets(ShName) ' آخر عمود في الصف الاول لورقة الشهر زايدا واحد c = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1 ' نقل التاريخ واسم الكورس وغيره في الصفوف الاربعة الاولى .Cells(1, c).Value = Range("C1").Value .Cells(2, c).Value = Range("K1").Value .Cells(3, c).Value = Range("K2").Value .Cells(4, c).Value = Range("K3").Value ' آخر صف في العمود الاول لورقة الشهر زايدا واحد Lr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 ' نقل التاريخ في الصفوف الاربعة في العمود الاول .Range("A" & Lr).Resize(4, 1).Value = Range("C1").Value ' نسخ الجدول Range("B7:L7").Resize(4).Copy ' لصق الجدول .Range("B" & Lr).PasteSpecial xlPasteValues End With Application.CutCopyMode = False ' مسح الجدول kh_Clear 1: Application.ScreenUpdating = True End Sub ' كود المسح بدون مسح المعادلات Sub kh_Clear() On Error Resume Next Range("B7:L7").Resize(4).SpecialCells(xlCellTypeConstants).ClearContents On Error GoTo 0 End Sub تحياتي نظام حضور الدورات التدريبية++.rar

السلام عليكم كود الترحيل Sub kh_Trheel() Dim ShName As String Dim Lr As Long Dim c As Integer ShName = Format(Range("C1"), "mmmm") Application.ScreenUpdating = False On Error GoTo 1 With Worksheets(ShName) c = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1 .Cells(1, c).Value = Range("C1").Value .Cells(2, c).Resize(3, 1).Value = Range("K1:K3").Value Lr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 .Range("A" & Lr).Resize(4, 1).Value = Range("C1").Value Range("B7:L7").Resize(4).Copy .Range("B" & Lr).PasteSpecial xlPasteValues End With Application.CutCopyMode = False kh_Clear 1: Application.ScreenUpdating = True End Sub كود المسح وابقاء المعادلات ' كود المسح بدون مسح المعادلات Sub kh_Clear() On Error Resume Next Range("B7:L7").Resize(4).SpecialCells(xlCellTypeConstants).ClearContents On Error GoTo 0 End Sub شاهد المرفق 2010 نظام حضور الدورات التدريبية+.rar

السلام عليكم جرب الكود التالي للترحيل Sub Macro1() Dim ShName As String Dim Lr As Long ShName = Format(Range("C1"), "MMMM") With Worksheets(ShName) Lr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 .Range("A" & Lr).Resize(4, 1).Value = Range("C1").Value Range("B7:L7").Resize(4).Copy .Range("B" & Lr).PasteSpecial xlPasteValues End With Application.CutCopyMode = False End Sub المرفق 2010 نظام حضور الدورات التدريبية.rar تحياتي

الحمد لله جزاكم الله خيرا

السلام عليكم جرب هذا للعمود A Sub Macro1() Dim cont As Double cont = Application.InputBox("اكتب الكمية", "", 1, , , , , 1) If cont = 0 Then GoTo 1 With Cells(Rows.Count, "A").End(xlUp) .Offset(1, 0) = Date .Offset(1, 1) = cont .Offset(1, 2) = cont * 10.5 End With 1: End Sub كرر الكود للعمود F و K تحياتي

السلام عليكم جزاكم الله خيرا وكل عام وانتم بخير تقبلوا تحياتي وشكري

جزاكم الله خيرا وبارك فيكم وكل عام وانتم بخير تقبلوا تحياتي وشكري

جزاكم الله خيرا وبارك فيكم وكل عام وانتم بخير تقبلوا تحياتي وشكري

جزاكم الله خيرا وبارك فيكم وكل عام وانتم بخير تقبلوا تحياتي وشكري

جزاكم الله خيرا وبارك فيكم وكل عام وانتم بخير تقبلوا تحياتي وشكري

جزاكم الله خيرا وبارك فيكم وكل عام وانتم بخير تقبلوا تحياتي وشكري

السلام عليكم جرب التالي Sub kh_Start() Dim Cel As Range Dim r As Integer, rr As Integer, c As Integer For Each Cel In Range("C6:C12") rr = Val(Cel) If rr Then c = WorksheetFunction.Match([D3], ورقة2.Range("C1:bb1"), 0) + 1 With ورقة2.Range("A3").Cells(rr, c) .Offset(0, 1).Value = Cel.Offset(0, 2).Value .Offset(0, 2).Value = Cel.Offset(0, 3).Value End With End If Next Range("c6:c12,e6:e12,f6:f12").ClearContents Call غ End Sub تحياتي

السلام عليكم هذا تعديل على الكود اسرع Sub kh_AddColr() Dim v, ww Dim r As Integer, c As Integer, cc As Integer Set ww = Application.WorksheetFunction On Error Resume Next Application.ScreenUpdating = False v = 9846527 With Range("C3:AN33") .Interior.ColorIndex = xlNone For r = 1 To .Rows.Count For c = 1 To .Columns.Count If ww.CountIf(.Rows(r), .Cells(r, c).Value) > 1 Then cc = ww.Match(.Cells(r, c).Value, .Rows(r), 0) If cc < c Then .Cells(r, c).Interior.Color = .Cells(r, cc).Interior.Color Else .Cells(r, c).Interior.Color = v v = v + 10000 End If End If Next Next End With Application.ScreenUpdating = True On Error GoTo 0 End Sub تحياتي

ممكن هكذا لكن قد يتاخر الكود شوية حسب عدد الصفوف والاعمدة التعديل في هذا السطر فقط For Each cc In Range(Cells(3, 3), Cells(r, c)) وهذا الكود بعد التعديل Sub CLR_DUP() Dim v, cc On Error Resume Next Dim r As Integer, c As Integer Set ww = Application.WorksheetFunction Application.ScreenUpdating = False Range("C3:AN33").Interior.Color = xlNone v = 9846527 For r = 3 To 33 For c = 3 To 38 If ww.CountIf(Range(Cells(r, 3), Cells(r, 38)), Cells(r, c).Value) > 1 Then Cells(r, c).Interior.Color = v For Each cc In Range(Cells(3, 3), Cells(r, c)) If cc.Value = Cells(r, c).Value Then Cells(r, c).Interior.Color = cc.Interior.Color Exit For End If Next v = v + 10000 End If Next Next Application.ScreenUpdating = True On Error GoTo 0 End Sub تحياتي

السلام عليكم او هذا اسرع وافضل Sub CLR_DUP() Dim v, cc On Error Resume Next Dim r As Integer, c As Integer Set ww = Application.WorksheetFunction Application.ScreenUpdating = False Range("C3:AN33").Interior.Color = xlNone v = 9846527 For r = 3 To 33 For c = 3 To 38 If ww.CountIf(Range(Cells(r, 3), Cells(r, 38)), Cells(r, c).Value) > 1 Then Cells(r, c).Interior.Color = v For Each cc In Range(Cells(r, 3), Cells(r, c)) If cc.Value = Cells(r, c).Value Then Cells(r, c).Interior.Color = cc.Interior.Color Exit For End If Next v = v + 10000 End If Next Next Application.ScreenUpdating = True On Error GoTo 0 End Sub

السلام عليكم جرب التعديل التالي Sub CLR_DUP() Dim v, cc On Error Resume Next Dim r As Integer, c As Integer Set ww = Application.WorksheetFunction Application.ScreenUpdating = False Range("C3:AN33").Interior.Color = xlNone v = 9846527 For r = 3 To 33 For c = 3 To 38 If ww.CountIf(Range(Cells(r, 3), Cells(r, 38)), Cells(r, c).Value) > 1 Then Cells(r, c).Interior.Color = v For Each cc In Range(Cells(r, 3), Cells(r, c)) If cc.Value = Cells(r, c).Value Then Cells(r, c).Interior.Color = cc.Interior.Color Else v = v + 10000 End If Next End If Next Next Application.ScreenUpdating = True On Error GoTo 0 End Sub المرفق 2010 CLR_DUP.rar

السلام عليكم شاهد المرفق 2010 ترتيب.rar

السلام عليكم جرب المعادلة التالية =COUNTIF($A$2:$A$57;"*"&E1&"*") تحياتي