عبدالله المجرب

السلام عليكم قمت بعمل دالة للتعرف على التاريخ الهجري وتحويله الى ميلادي للتعامل معه الدالة DATEDIF Function MyDate(MyCel As String) Calendar = vbCalHijri If IsDate(MyCel) Then MyDate = CDate(MyCel) End Function جرب المرفق الفرق بين تاريخين.rar

استطيع عملها بكود فما رايك

السلام عليكم اخواني الكرام كثرت في الاونة الاخيرة الطلبات التي تحمل عناوين غير مناسبة ومخالفة لقواعد المشاركة http://www.officena....s/Questions.htm في كثير من الاحيان تم اتخاذ بعض الحلول كتغيير العنوان والتنبيه في حينه لكن دون جدوى ثم موخراً تم العمل على اغلاق وحذف المشاركات المخالفه لكن نجد ان العنوان غير مناسب وبه ردوود من بعض الاخوة (حل) دون النظر الى هذا الجانب وعليه اوجه ندائي الى كل من يملك الحل لموضوع مخالف ان لا يضع الحل وان يضع مكانه تنبيه الى ان الموضوع مخالف باستخدام خيار التبليغ اسفل المشاركة الى ان يتم اتخاذ اجراء من المراقبين او المشرفين كتعديل العنوان او اغلاق الموضوع او غيره وذلك للوصول الى التزام من الاخوة في وضع عناوين ووصف يدل على الطلب ================ عن نفسي ارى ان يتم الحزم في هذه المسالة فقد تفاقمت وساقوم بإخفاء اي مشاركة (حل) لأي موضوع مخالف واغلاقه فهذه المواضع باتت تشكل عبئ في الاضافة الى النشرة الدورية. والله من وراء القصد

تم تعديل الموضوع للدلالة

بالفعل تجد الكل مشغول هذه الايام بسبب الامتحانات نرجو المعذرة سوال لماذ تضع هذا الكود في حدث اغلب التكست بوكس Private Sub TextBox36_Change() TextBox11_Change End Sub ثم هل المطلوب البحث

لحماية المعادلات قم بالتالي 1. ضلل جميع الخلايا 2. من تنسيق الخلايا اختر حماية 3. قم بازالة علامة الصح من خياري التامين والاخفاء ثم اختر موافق ======= 4. اضغط في اي مكان في المستند ثم اضغط F5 5. في مربع الحوار اختر خاص ثم اختر الصيغ (سيتم تضليل الخلايا التي تحوي معادلات) 6. والمؤشر على اي خلية مضللة اختر تنسيق خلايا ثم حماية وضع صح على خياري التامين والاخفاء ثم موافق 7. من حماية ضع كلمة مرور وسيتم حماية المعادلات من التعديل او الحذف

بارك الله فيك اخي رجب

السلام عليكم جرب هذا التعديل على كود الاخ رجب Sub Ragab() Dim LR As Integer Dim KH As Range Dim KH_1 As Range LR = Cells(Rows.Count, 1).End(xlUp).Row Application.ScreenUpdating = False With ActiveSheet Set KH = .Range("B11:Z" & LR) Set KH_1 = .Range("B11:Z" & LR) KH.Sort Key1:=Cells(11, 2), Order1:=xlAscending KH_1.Sort Key1:=Cells(11, 5), Order1:=xlAscending End With Application.ScreenUpdating = True End Sub

انتظر الحل مع الشرح ان شاء الله لكني اطلب الوقت بسبب ظروف امتحانات الاولاد

السلام عليكم ما هذا الابداع يا ابا علي ما شاء الله سلمت الايادي احتراف واضح لا تخطئه العين بارك الله فيك ============= اخي الفاضل bast لتعديل كلمة المرور ادخل الاسم وكلمة المرور القديمة وستظهر لك فورم التعديل

السلام عليكم هذا التعديل على كود الاخ رجب ان شاء الله يفي بالغرض Sub Ragab() Dim R As Integer Dim LR As Integer Dim KH As Range Dim KH_1 As Range Dim KH_2 As Range LR = Cells(Rows.Count, 1).End(xlUp).Row R = Application.CountIf(Range("b6:b" & LR), "ذكر") + 5 RR = R + 1 Application.ScreenUpdating = False With ActiveSheet Set KH = .Range("a6:b" & LR) Set KH_1 = .Range("a6:b" & R) Set KH_2 = .Range(Cells(RR, 1), Cells(LR, 2)) KH.Sort Key1:=Cells(6, 2), Order1:=xlAscending KH_1.Sort Key1:=Cells(6, 1), Order1:=xlAscending KH_2.Sort Key1:=Cells(RR, 1), Order1:=xlAscending End With Application.ScreenUpdating = True End Sub

اقصد ان الاسم أحمد مثلاً له صف مكتوب به اسمه وخليتين تحتها تتبع نفس الاسم هذا هو المقصود ب +2 اي خلية الاسم والخلييتن التي تحتها ولكن بعمود القيم

تفضل الورقة.rar

يمكنك التحكم في الصفوف والاعمدة

السلام عليكم الرقم 5 هو رقم العمود التي به الارقام التي ستجمع ======= الرقم 2 هي العدد المضاف الى صفوف تكرار الاسم ====== بمعنى 3 صفوف تجمع من العمود الخامس

جميل جداً معلومة جديدة بالنسبة لي

هذا بالنسبة لي ممكن في الاكسل وبانتظار الموافقة من قبلك لانه سيتم نقل الموضوع الى هناك (يفضل وضع تصور بجدول اكسل وارفاقه)

بعد إذن أخي ابو حنين تم عمل كود لعمل قائمة منسدلة مرنة بأسماء ورقات العمل الورقة.rar

هذا تعديل على الكود Sub Abu_Ahmed() Dim cl As Range Application.ScreenUpdating = False Set MySh = Sheets("Sheet2") [K2:L300].ClearContents MySh.[B6:C300].ClearContents For i = 6 To [C10000].End(xlUp).Row If InStr(Cells(i, 3), "(") = 0 Then GoTo 1 R = Mid(Cells(i, 3), InStr(Cells(i, 3), "(") + 1, Len(Mid(Cells(i, 3), (InStr(Cells(i, 3), "(") + 1), 10)) - 1) T = Mid(Cells(i, 3), 1, InStr(Cells(i, 3), "(") - 1) Range("K" & [K10000].End(xlUp).Row + 1) = T Range("L" & [L10000].End(xlUp).Row + 1) = R 1 Next For Each cl In Range("C6:C" & [C10000].End(xlUp).Row) If InStr(cl, "(") = 0 Then GoTo 2 RR = Mid(cl, InStr(cl, "(") + 1, Len(Mid(cl, (InStr(cl, "(") + 1), 10)) - 1) w = Application.CountIf([L2:L100], RR) If Application.CountIf([L2:L100], RR) > 1 Then MySh.Range("C" & MySh.[C10000].End(xlUp).Row + 1) = cl TT = Mid(cl, 1, InStr(cl, "(") - 1) WW = Application.CountIf([K2:K100], TT) If WW > 1 Then MySh.Range("B" & MySh.[B10000].End(xlUp).Row + 1) = cl 2 Next [K2:L300].ClearContents Set MySh = Nothing End Sub

السلام عليكم عمل جميل إضافة رائعة من الاستاذ بن عليه ========= هذا الرابط به برنامج لحل لعبة السودوكو http://www.officena.net/ib/index.php?showtopic=38258

السلام عليكم جرب هذا الكود Sub Abu_Ahmed() Dim cl As Range Application.ScreenUpdating = False Set MySh = Sheets("Sheet2") [K2:L300].ClearContents MySh.[B6:C300].ClearContents For i = 6 To [C10000].End(xlUp).Row R = Mid(Cells(i, 3), InStr(Cells(i, 3), "(") + 1, Len(Mid(Cells(i, 3), (InStr(Cells(i, 3), "(") + 1), 10)) - 1) T = Mid(Cells(i, 3), 1, InStr(Cells(i, 3), "(") - 1) Range("K" & [K10000].End(xlUp).Row + 1) = T Range("L" & [L10000].End(xlUp).Row + 1) = R Next For Each cl In Range("C6:C" & [C10000].End(xlUp).Row) RR = Mid(cl, InStr(cl, "(") + 1, Len(Mid(cl, (InStr(cl, "(") + 1), 10)) - 1) w = Application.CountIf([L2:L100], RR) If Application.CountIf([L2:L100], RR) > 1 Then MySh.Range("C" & MySh.[C10000].End(xlUp).Row + 1) = cl TT = Mid(cl, 1, InStr(cl, "(") - 1) WW = Application.CountIf([K2:K100], TT) If WW > 1 Then MySh.Range("B" & MySh.[B10000].End(xlUp).Row + 1) = cl Next [K2:L300].ClearContents Set MySh = Nothing End Sub

بارك الله فيك استاذ جمال على هذا العمل المميز

السلام عليكم جرب هذا التعديل معادلة التفقيط لكل الاكسيل.rar

هل ستحدد نوع الجنس ام ماذا

عمل مميز وبصمة رائعة بارك الله فيك اخي ابو حنين