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

السلام عليكم جرب الكود التالي: Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Dim CC As Integer, C As Integer Dim sR As String Dim MyRng As Range Set MyRng = Range("E8:AN78") If Not Intersect(Target, MyRng.Cells) Is Nothing Then Application.EnableEvents = False CC = MyRng.Column - 1 C = Target.Column - CC sR = MyRng.Columns(C).Address If Application.CountIf(Range(sR), Target.Value) > 1 Then If MsgBox("تم إسناد هذا الصف لمعلم آخر ......." & vbLf & vbLf & "هل تريد المتابعة ؟", 16 + vbYesNo + 524288 + 1048576, "تاكيد") = vbNo Then Target.ClearContents End If End If Kh_ColorIndex Range(sR) Application.EnableEvents = True End If On Error GoTo 0 End Sub ----------------------------------------- Private Sub Kh_ColorIndex(Mycel As Range) Dim cel As Range Application.ScreenUpdating = False For Each cel In Mycel If cel <> "" And Application.CountIf(Mycel, cel) > 1 Then cel.Interior.ColorIndex = 39 Else cel.Interior.ColorIndex = xlNone End If Next Application.ScreenUpdating = False End Sub مرفق ملف خبور خير abusarah73-22.rar

======================== الاخ الحبيب/ اكرم الغامدي ======================== عمل رائع جداً جداً سلمت يداك و

======================== الاخ الحبيب/ ابو هادي ======================== حمد لله على السلامة

======================== الاخ الفاضل / نور الدين ========================

السلام عليكم تم التنفيذ خبور خير elnour.rar

======================== الاخ الحبيب/ الحسامي ========================

======================== الاخ الحبيب/ طارق ========================

السلام عليكم الاخ الحبيب/ عادل ------ حفظه الله اكرمك الله في الدارين و جزاك الله خيرا ================================= الاخ الحبيب/ طارق------ حفظه الله اللهم لك الحمد كما ينبغي لجلال وجهك وعظيم سلطانك ادام الله المحبه فيه لك حبي وامتناني ودمتم في حفظ الله

السلام عليكم الاخ الفاضل/ مصطفى الفيومي------ حفظه الله جزاك الله خيرا الاخ الفاضل/ قصي------ حفظه الله جزاك الله خيرا الاخ الفاضل/ ابو سارة------ حفظه الله اكرمك الله في الدارين و جزاك الله خيرا الاخ الفاضل/ ياسر خليل------ حفظه الله اكرمك الله في الدارين و جزاك الله خيرا الاخ الفاضل/ ولد طيبة------ حفظه الله اكرمك الله في الدارين و جزاك الله خيرا الاخ الفاضل/ آيسم ابراهيم------ حفظه الله اكرمك الله في الدارين و جزاك الله خيرا الاخ الفاضل/ ابو عبدالله ------ حفظه الله اكرمك الله في الدارين و جزاك الله خيرا الاخ الفاضل/ ابو العقاب------ حفظه الله اكرمك الله في الدارين و جزاك الله خيرا الاخ الفاضل/ محمدي عبد السميع ------ حفظه الله اكرمك الله في الدارين و جزاك الله خيرا الاخ الفاضل/ الحسامي------ حفظه الله اكرمك الله في الدارين و جزاك الله خيرا تقبلوا تحياتي وشكري

السلام عليكم الاخ الفاضل/ قصي------ حفظه الله جزاك الله خيرا الاخ الفاضل/ ابو عبدالله ------ حفظه الله اكرمك الله في الدارين و جزاك الله خيرا الاخ الفاضل/ ابو سارة------ حفظه الله اكرمك الله في الدارين و جزاك الله خيرا الاخ الفاضل/ ياسر خليل------ حفظه الله اكرمك الله في الدارين و جزاك الله خيرا الاخ الفاضل/ محمدي عبد السميع ------ حفظه الله اكرمك الله في الدارين و جزاك الله خيرا الاخ الفاضل/ ezzarqtouni------ حفظه الله اكرمك الله في الدارين و جزاك الله خيرا الاخ الفاضل/ الحسامي------ حفظه الله اكرمك الله في الدارين و جزاك الله خيرا تقبلوا تحياتي وشكري

السلام عليكم الاخ الحبيب/ الحسامي------ حفظه الله اكرمك الله في الدارين وجزاك الله خيرا تقبل تحياتي وشكري

السلام عليكم الاخ الفاضل / مصطفى الفيومي------ حفظه الله الاخ الحبيب/ محمدي عبد السميع------ حفظه الله جزاكما الله خيرا تقبلا تحياتي وشكري ==================================================== الاخ الحبيب/ طارق ------ حفظه الله جرب الدالة ادناه: اذا اردت الرقم العشري عين Kh_Point تساوي True او اي رقم غير الصفر مثلا: =Kh_Replace_Text($A4;1;1) منتظر ردك ==================================================== Option Explicit ' بسم الله الرحمن الرحيم " ' ********************* " ' دالة استخراج النص او الارقام " '==============================================" ' False = مهمل او Kh_Number اذا كان " ' تقوم باستخراج النص " ' True = Kh_Number اذا كان " ' تقوم باستخراج الارقام " ' ---------- " ' True = Kh_Point اذا كان " ' تقوم باستخراج الرقم العشري الاول " '==============================================" '----------------------------------------------------------------- Function Kh_Replace_Text(ByVal Kh_Sub As String, Optional Kh_Number As Boolean, Optional Kh_Point As Boolean) Dim Num As Byte, C As Integer Dim Sn As String, Re As String, Md As String Sn = Trim(Kh_Sub) For Num = 0 To 9 Sn = Replace(Sn, Num, "") Next Num If Kh_Number Then Re = Trim(Kh_Sub) Do While C < Len(Trim(Sn)) C = C + 1 Md = Mid(Sn, C, 1) If Kh_Point Then If Md = "." Then GoTo 1 Re = Replace(Re, Md, "") 1 Loop Kh_Replace_Text = Val(Re) Else Kh_Replace_Text = Trim(Sn) End If End Function ======================================================== دالة استخراج النص او الارقام1.rar

السلام عليكم Option Explicit ' بسم الله الرحمن الرحيم " ' ********************* " ' دالة استخراج النص او الارقام " '==============================================" ' False = مهمل او Kh_Number اذا كان " ' تقوم باستخراج النص " ' True = Kh_Number اذا كان " ' تقوم باستخراج الارقام " '==============================================" '----------------------------------------------------------------- Function Kh_Replace_Text(ByVal Kh_Sub As String, Optional Kh_Number As Boolean) Dim Num As Byte, C As Integer Dim Sn As String, Re As String, Md As String Sn = Trim(Kh_Sub) For Num = 0 To 9 Sn = Replace(Sn, Num, "") Next Num If Kh_Number Then Re = Trim(Kh_Sub) Do While C < Len(Trim(Sn)) C = C + 1 Md = Mid(Sn, C, 1) Re = Replace(Re, Md, "") Loop Kh_Replace_Text = CDbl(Re) Else Kh_Replace_Text = Trim(Sn) End If End Function دالة استخراج النص او الارقام.rar

السلام عليكم Option Explicit ' بسم الله الرحمن الرحيم " ' ******************** " ' دالة استخراج اسم ولي الأمر " '========================================" ' يامكانية معالجة الاسم المركب الاول " ' تلقائياً حسب معايير معرفة لديها " ' Kh_Father_Replace في الدالة " ' ويمكنك اضافة اي معيار آخر " ' بجانب المعايير الموجودة " ' MyArray في المتغير " ' مع مراعاة وجود فراغ بداية ' او نهاية المعيار '========================================" '----------------------------------------------------------------- Function Kh_Father_Name(ByVal Name As String) As String Dim KhString As String, SearchChar As String, Kh_Mid As String, Kh_Rep As String Dim KhMyNo As Integer On Error GoTo Err_Kh_Father_Name If IsEmpty(Name) Then GoTo Err_Kh_Father_Name KhString = Kh_Father_Replace(Trim(Name)) & " " SearchChar = " " KhMyNo = InStr(1, KhString, SearchChar, 1) Kh_Mid = Trim(Mid(KhString, KhMyNo, Len(KhString))) Kh_Rep = Replace(Kh_Mid, "_", " ") Kh_Father_Name = Kh_Rep Exit Function Err_Kh_Father_Name: Kh_Father_Name = "" End Function Private Function Kh_Father_Replace(ByVal Kh_Sub As String) As String Dim MyArray, Ar Dim Sn As String, Re As String '==================================================== ' يمكنك اضافة اي معيار آخر هنا بجانب المعايير الموجودة MyArray = Array("عبد ", "أبو ", "ابو ", "آل ", " الله" _ , " الدين", " الإسلام", " الاسلام", " الحق") '==================================================== Sn = Kh_Sub For Each Ar In MyArray Re = Replace(Ar, " ", "_") Sn = Replace(Sn, Ar, Re) Next Kh_Father_Replace = Sn End Function استخراج اسم ولي الامر.rar

السلام عليكم Option Explicit ' بسم الله الرحمن الرحيم " '======================================" ' دالة استخراج الاسماء من اسم مركب طويل ' kh_index بدلالة ترتيب الاسم '======================================" ' kh_index ' اذا كانت مهملة او نصاً او صفرا ' تقوم باستخراج الاسم الاول '======================================" ' وهي تقوم بإستخراج الاسماء المركبة ' للاسم الواجد ' تلقائياً حسب معايير معرفة لديها ' MyArray في متغير الجدول ' ويمكنك اضافة اي معيار آخر ' بجانب المعايير الموجودة ' مع مراعاة وجود فراغ بداية ' او نهاية المعيار '======================================" '----------------------------------------------------------------- Function kh_Name(Name As String, Optional kh_index = 1) As String Dim kh_ind As Integer Dim kh_Split, MyArray, Ar Dim Kh_String As String, Sn As String, Re As String, kh_Split_index As String, Kh_Rep As String On Error GoTo Err_Kh_Name kh_ind = Val(kh_index) If kh_ind = 0 Then kh_ind = 1 '====================================== MyArray = Array("عبد ", "أبو ", "ابو ", "آل " _ , " الله", " الدين", " الإسلام", " الاسلام", " الحق") '====================================== Sn = Application.WorksheetFunction.Trim(Name) For Each Ar In MyArray Re = Replace(Ar, " ", "^") Sn = Replace(Sn, Ar, Re) Next '====================================== Kh_String = Sn kh_Split = Split(Kh_String, " ", , vbTextCompare) kh_Split_index = kh_Split(kh_ind - 1) Kh_Rep = Replace(kh_Split_index, "^", " ") kh_Name = Kh_Rep Exit Function Err_Kh_Name: kh_Name = "" End Function تجزئة الاسماء من اسم طويل.rar

السلام عليكم بارك الله فيك اخي الحسامي و بارك الله فيك اخي طارق فقط أيضا للإثراء حل اخر بالمعادلات بامكانه استعمال الاسم kh_list كقائمة والذي يحوي على المعادلة =IF(ورقة1!$L$3="";INDEX(قائمة_الفروع;0;2);OFFSET(ورقة1!$E$2;MATCH(ورقة1!$L$3;INDEX(قائمة_الفروع;0;1);0);;COUNTIF(INDEX(قائمة_الفروع;0;1);ورقة1!$L$3))) خبور خير قائمة منسدلة مرتبطة بقائمة أخرى بالمعادلات.rar

السلام عليكم بمجرد الاختيار في الخلية M3 سيغمل الكود Private Sub Worksheet_Change(ByVal Target As Range) Dim Y As Integer, R As Integer If Target.Address = Range("M3").Address Then Me.Range("H3:I20").ClearContents With Range("قائمة_الفروع") For Y = 1 To .Rows.Count If IsError(Target.Offset(0, -1)) Then GoTo 1 If .Cells(Y, 1).Value = Target.Offset(0, -1).Value Then Cells(R + 3, "H").Value = .Cells(Y, 2).Value Cells(R + 3, "I").Value = .Cells(Y, 3).Value R = R + 1 End If Next End With End If 1: End Sub قائمة منسدلة مرتبطة بقائمة أخرى.rar

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

السلام عليكم بارك الله فيك اخي الحسامي وبعد اذنك دي محاولة حسب ما فهمت من الطلب والله اعلم Private Sub CommandButton1_Click() Dim I As Integer, Z As Integer, R As Integer Range("C4:F25").ClearContents For I = 1 To 4 R = 0 Z = Val(Me.Controls("TextBox" & I)) Do While R < Z R = R + 1 Cells(3 + R, I + 2).Value = I & "م" & R Loop Me.Controls("TextBox" & I).Value = "" Next I End Sub خبور خير الصفوف3.rar

السلام عليكم اي كود او معادلة ستتعامل مع 54000 صف وبالشروط التي تريدها اكيد ستاخذ الكثير من الوقت ايه الداعي لحساب هذه الكم في آن واحد ؟؟ بامكانك تحجيم ما تريده حسب طلبك خبور خير

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

السلام عليكم بامكانك استخدام معادلة الصفيف التالية: {=INDIRECT("R" & MAX(IF(B2:B10="";"";ROW(B2:B10)))&"C";0)} ملاحظة: بعد ادخال الصيغة اضغط CTRL+SHIFT+ENTER. شاهد المرفق SER.rar

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

السلام عليكم اضافة الى كود الاخ Kemas بارك الله فيه والذي ممكن تعدل فيه ليشمل نطاق الخلايا الماخوذ من الورقة DATA صفوف معينة مثلا من 1:1500 Sub testo() Sheets("result").Select Range("e2:e100").Formula = "=SUMPRODUCT((DATA!B1:B1500<A2)*(DATA!M1:M1500=$h$1)*(DATA!A1:A1500=B2)*(DATA!W1:W1500))" Range("e2:e100").Cells = Range("e2:e100").Value End Sub ==================================== طريقة اخرى الاسم MYRNG هو نطاق الخلايا DATA!A1:W1500 Sub kh_Evaluate() Dim Rng As Range, N As Range Set Rng = Sheets("Result").Range("E2:E100") Rng.ClearContents For Each N In Rng N = Application.Evaluate("SUMPRODUCT((INDEX(MYRNG,0,13)=" & Range("H1").Address & ")*(INDEX(MYRNG,0,1)=" & Cells(N.Row, 2).Address & ")*(INDEX(MYRNG,0,2)<" & Cells(N.Row, 1).Address & ")*INDEX(MYRNG,0,23))") Next End Sub ===================================== طريقة اخرى بدون استخدام الدالة SUMPRODUCT بالكود مباشرة: Option Explicit Sub Kh_SumRange() Dim i As Integer Range("E2:E100").ClearContents Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With Sheets("Result") For i = 2 To 100 .Cells(i, "E") = Kh_Sum(.Cells(i, "A"), .Cells(i, "B")) Next i End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub --------------------------------------- Function Kh_Sum(Colmn_A As Range, Colmn_B As Range) Dim Z As Double Dim R As Long, Last As Long With Sheets("DATA") Last = .Range("A" & .Rows.Count).End(xlUp).Row For R = 1 To Last If .Cells(R, "M") = "MOHAMMED" Then If .Cells(R, "A") = Colmn_B Then If .Cells(R, "B") < Colmn_A Then Z = Z + .Cells(R, "W") End If End If End If Next R End With Kh_Sum = Z End Function شاهد المرفق خبور خير تحويل معادلة الى كود.rar

السلام عليكم بارك الله فيك اخي الخالدي مغلومات مفيده جزاك الله خيرا والشكر واصل لجميع المشاركين حفظكم الله جميعاً خبور خير