الـعيدروس

اتمنى يكون الشرح واضح

الحمد لله انه زبط معك تقبل تحياتي وشكري

تم التعديل بما يتناسب مع طلبك اخي صالح شاهد المرفق كود انتقال_222.rar

بالامكان بهذا الشكل انسخ الكود والصقه في حدث الورقة Private Const Ad_r As String = "$A$1" '' خلية شرط تطابق القيمة Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 And Target.Row > 1 Then With Target If .Value = Val(Range(Ad_r)) Then .Resize(1, 5).Interior.ColorIndex = 6 Else .Resize(1, 5).Interior.Pattern = xlNone End If End With End If End Sub

ممكن بغير كود اتبع الشرح في المرفق شرح_111.rar

السلام عليكم اختى الكريمة تم الرد على موضوعك السابق بأكثر من حل ؟ على العموم تفضلي المرفق وبه الكود اكتبي التاريخ في خلية B3 وانقري انتر تحياتي كود انتقال_111.rar

السلام عليكم لا عليك اخي ابو ليالى حفظها الله لك وتتربى في عزك ان شاء الله اطلع على المرفق وجرب ان شاء الله به ماتريد واي تعديلات او ملاحظات نحن بالخدمة تحياتي رصد درجات الفصول فى الكنترول_111.rar

ملاحظ عدد المواد تختلف للصف الرابع والصف الثالث ؟ هل ممكن تحط امثله للصفوف التي تتعامل معها مثال : ورقة للصف الاول والثاني والثالث الخ ... حتى اعرف فروقات اعمدة المواد واحط شروط ع الكود

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

لم تقم بإضافة كود الدالة ؟ شاهد المرفق ملفك وبه الكود Book1_111.rar

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

استخدم الدالة المعرفه التاليه Public Function f(N) Dim S As String S = Split(Replace(N, "/", ""), " ")(1) f = S End Function واستدعيها كالتالي =f(A1)

شاهد المرفق شرح_6.rar

ارفق مثال وشرح مبسط وان شاء الله خير

السلام عليكم الاخ والاستاذ ياسر خليل شرح رائع وموفق انت "جامعه" تقبل مروري

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

اذا تقصد ترحيل من الصف الى ورقة رصد الدرجات جرب الكود التالي Sub Ali() Dim R1 As Range Dim R2 As Range Dim Wr As Worksheet Dim Mysh As Worksheet Dim Ary() As Variant Dim X, C, Ro Set Mysh = Sheets("رصد الدرجات") Set R1 = Mysh.[D1]: Set R2 = Mysh.[D3] For Each Wr In Worksheets With Wr If Trim(Split(.Name, " ")(1)) = R1 Then Lr = .Cells(.Rows.Count, 3).End(xlUp).Row For Rw = 5 To Lr If Val(Trim(.Cells(Rw, 4))) = Val(Trim(R2)) Then Ro = .Cells(Rw, 1).Row X = X + 1 ReDim Preserve Ary(1 To Lr, 1 To 9) For C = 1 To 9 Ary(X, C) = .Cells(Ro, C + 1) Next C End If Next Rw End If End With Next Wr Mysh.Range("B7").Resize(UBound(Ary, 1), UBound(Ary, 2)) = Ary() Erase Ary End Sub

السلام عليكم هكذا Sub Auto_Open() '' يتفعل عند الدخول للمصنف او عند تشغيل الكود Application.OnKey "%{F8}", "" End Sub لإعادة تفعيل الخاصيه كالتالي Sub Re_Ali() '' لإعادة تفعيل الخاصيه Application.OnKey "%{F8}" End Sub

هكذا If Application.Version = "14.0" Or Application.Version = "12.0" Then او شرطين معاً If Application.Version = "14.0" And Application.Version = "12.0" Then

انقر الخيار الاوسط للرسالة وشوف بأي سطر الخطاء الذي اشار اليه باللون الاصفر

فعلاً الكود لاينفذ شيء سأعمل عليه لاحقاً ان شاء الله

جرب هذا التعديل Sub Ali_Merg_Data1() Dim R As Range Dim Rng As Range Dim My_r As Range Dim X_r As Double Dim Ing As Variant On Error Resume Next For Each R In Range("A6:A" & Ali_Last(Range("A6:A2000"), "*")) If R <> "*" Then If Not R Is Nothing Then If Rng Is Nothing Then Set Rng = R Else Set Rng = Union(Rng, R) End If End If Next R 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx If Not Rng Is Nothing Then For Each Ing In Split(Ali_My_Rng(Rng.Offset(0, 5), Rng.Offset(0, 7), Rng.Offset(0, 8)), ",") Set My_r = Range(Ing) X_r = Alr_Cn(My_r) With My_r .ClearContents .Merge .Value = X_r End With Next End If On Error GoTo 0 Set Rng = Nothing: Set R = Nothing Set My_r = Nothing 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx End Sub Private Function Alr_Cn(R As Range) Dim i Dim Sm Dim Sn As String With R For i = 1 To .Rows.Count If Not IsNumeric(.Cells(i, 1)) Then Sm = .Cells(1, 1) Else Sm = Sm + .Cells(i, 1) End If Next i If Sm Then Alr_Cn = Sm End With End Function Private Function Ali_Last(Rnge As Range, F_Tx$) Dim vv Application.ScreenUpdating = False For vv = Rnge(Rnge.Count).Row To Rnge(1).Row Step -1 If Cells(vv, Rnge.Column) = F_Tx Then Ali_Last = vv Exit Function End If Next vv Application.ScreenUpdating = True End Function Private Function Ali_My_Rng(ParamArray Rngs() As Variant) As String Dim N As Long Dim R As Range Dim T As String For N = LBound(Rngs) To UBound(Rngs) If Not Rngs(N) Is Nothing Then For Each R In Rngs(N).Areas T = T & "," & R.Address Next R End If Next N Ali_My_Rng = Mid(T, 2, Len(T)) End Function

السلام عليكم او بالكود التالي لاثراء الموضوع Sub Ali_Rng_Find() Dim Rng As Range, Rn As Range, R As Range Set Rn = [B3] '' خلية شرط البحث For Each Rng In ActiveSheet.UsedRange If Rng.Value = Rn.Value And IsDate(Rn) And _ Rng.Address <> Rn.Address Then If Not Rng Is Nothing Then If R Is Nothing Then _ Set R = Rng Else Set R = Union(R, Rng) End If Next Rng If Not R Is Nothing Then R.Interior.ColorIndex = 3: R.Activate Set Rng = Nothing: Set Rn = Nothing: Set R = Nothing End Sub

اخي الكريم ابو عبدالرحمن المرفق الاول توضيح والاخر ملفك وبه الكود وزر ترحيل انقر عليه لتشغيل الكود تقبل تحياتي وشكري توضيح.rar برنامج الوزارات مرتب على واجهة تحتوي على ازرار_111.rar

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