ياسر خليل أبو البراء

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

الأخ الحبيب خالد تصحيح للمعلومة فقط ..هذه الدالة المقدمة ليست من ضمن دوال الإكسيل ، إنما هي دالة تم صنعها بالأكواد لتؤدي نفس الغرض الذي تؤديه الدالة المدمجة بالإكسيل ، مع تلافي عيوبها كما هو موضح بالمرفق .. تقبل تحياتي

مشكور أخي الفاضل أبو بهاء المصري بارك الله فيك على مرورك العطر

بارك الله لك في ملك يا أبا ملك .. وجعل الملك صحبتك في الدنيا والآخرة .. تقبل تحياتي

الأخ الفاضل خالد جرب الملف التالي .. Nageh Raseb Tarhil.rar

أخي الفاضل الباحث العربي ... مشكور على ردك الجميل أخي العربي رداً على قولك ألا اأمل من طلباتك ..أؤكد لك أنه لن يحدث بإذن الله .. بس إوعى إنت تمل من متابعة المنتدى ... إخوانك سيكونون في انتظارك .. فلا تطول عليهم الانتظار تقبل تحياتي

أخي حاول أن تدرج المعادلة بنفسك وأبلغنا ما الخطأ الذي يظهر لك .. الموضو بسيط كما أخبرتك .. فقط انسخ المعادلة وضعها في الخلايا التي أشرت إليك .. هذا كل ما في الأمر حاول مرة أخرى وإذا فشلت فحاول مرة أخرى وإذا فشلت وهذا وارد حاول إلى أن تبلغ عدد محاولاتك 20 محاولة على الأقل ، فإذا فشلت وهذا وارد .. حاول غداً أو أبلغنا وستجد عربة الإسعاف في طريقها إليك بإذن الله

أخي الكريم ..إتماماً للأمر إليك الملف المرفق .. Date-Time-Computer Name Automatically.rar

أخي الفاضل تم ذلك .. لتجربة الكود قم بحذف الدوائر أولا ثم بتجربة الكود .. Not IsEmpty(c.Value) تقريبا هذه هي الإضافة التي أضفتها وضبطت الكود تقبل تحياتي

أخي الفاضل لم أنتبه لبقية كلامك .. إذا أردت تفعيل الكود على كافة أوراق العمل قم بوضع هذا الكود بهذا الشكل في حدث المصنف Workbook Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) If Target.Cells.Count > 1 Then Exit Sub If Not Intersect(Target, Range("A2:A100")) Is Nothing Then VBA.Calendar = vbCalHijri ' اذا كنت تريد التاريخ هجري 'VBA.Calendar = vbCalGreg ' إذا كنت تريد التاريخ ميلادي With Target(1, 4) ' العمود الاول والعمود المراد كتابة التاريخ والوقت فيه '.NumberFormat = "[$-1010000]yyyy/mm/dd;@" ' إذا كنت تريد التاريخ ميلادي .NumberFormat = "[$-2060000]B2yyyy/mm/dd;@" ' اذا كنت تريد التاريخ هجري .Value = Date & " _ " & Time ' يظهر التاريخ مع الوقت .EntireColumn.AutoFit ' توسيع العمود بقدر كبر التاريخ والوقت End With With Target(1, 5) .Value = Environ$("computername") End With End If End Sub

أخي الكريم الباحث العربي جرب التعديل البسيط Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.Count > 1 Then Exit Sub If Not Intersect(Target, Range("A2:A100")) Is Nothing Then VBA.Calendar = vbCalHijri ' اذا كنت تريد التاريخ هجري 'VBA.Calendar = vbCalGreg ' إذا كنت تريد التاريخ ميلادي With Target(1, 4) ' العمود الاول والعمود المراد كتابة التاريخ والوقت فيه '.NumberFormat = "[$-1010000]yyyy/mm/dd;@" ' إذا كنت تريد التاريخ ميلادي .NumberFormat = "[$-2060000]B2yyyy/mm/dd;@" ' اذا كنت تريد التاريخ هجري .Value = Date & " _ " & Time ' يظهر التاريخ مع الوقت .EntireColumn.AutoFit ' توسيع العمود بقدر كبر التاريخ والوقت End With With Target(1, 5) .Value = Environ$("computername") End With End If End Sub

بارك الله فيك يا أخ سليم .. والله كنت أظنك مصري بس طلعت الحمد لله سوداني الأخ السائل .. إليك هذا الرابط لعله يفيدك http://www.officena.net/ib/index.php?showtopic=59826

السلام عليكم ورحمة الله وبركاته إخواني الكرام .. لاحظت أن كل فترة يتم السؤال عن هذا الأمر .. هذا الموضوع يخص الأرقام القومية في مصر ، وقد تم تناول الموضوع أكثر من مرة .. واطلعت على أكثر من موضوع بهذا الشأن ، فما وجدت أفضل ولا أيسر ولا أخف من دالة الأستاذ الكبير / عبد الله باقشير ، دالة يسيرة وسهلة ، ويمكنك ببساطة استخراج كل المعلومات والبيانات التي تريدها من خلال هذه الدالة .. الشكر الكبير موصول للأستاذ الكبير والعالم الجليل عبد الله باقشير .. نرجو من الله أن يحفظه من كل سوء .. الدالة في محرر الأكواد بهذا الشكل : (للدخول على محرر الأكواد اضغط من لوحة المفاتيح Alt + F11) Option Explicit ' بسم الله الرحمن الرحيم ' ******************** ' دالـــــــــــــــة ' Kh_Date_Sex_Province ' ( استخراج تاريخ الميلاد او النوع (ذكر - انثى ' او المحافظة من الرقم القومي '============================================== ' MyTest ' اذا كانت = 1 تقوم باستخراج تاريخ الميلاد ' اذا كانت = 2 تقوم باستخراج النوع ' اذا كانت = 3 تقوم باستخراج المحافظة '---------------------------------------------- ' MyProvinces في متغير الجدول ' بنفس الطريقة الرقم اولا ثم "/" ثم اسم المحافظة ' : مثال على ذلك ' "01/القاهرة" '============================================== Function Kh_Date_Sex_Province(MyNumber As Variant, MyTest As Byte) Dim MyProvinces As Variant Dim r As Integer Dim yy As String Dim ty As String * 1 Dim d As String * 2, m As String * 2, y As String * 2 _ , x As String * 2, xx As String * 2 '============================================== MyProvinces = Array("01/القاهرة", "02/الإسكندرية", "12/الدقهلية", "13/الشرقية" _ , "14/القليوبية", "15/كفر الشيخ", "16/الغربية", "17/المنوفية", "18/البحيرة" _ , "19/الإسماعيلية", "21/الجيزة", "22/بني سويف", "24/المنيا", "25/أسيوط" _ , "26/سوهاج", "27/قنا", "28/أسوان", "29/الأقصر", "33/مطروح", "23/الفيوم", "88/خارج الجمهورية", "11/دمياط", "04/السويس", "03/بورسعيد", "34/شمال سيناء", "35/جنوب سيناء", "32/الوادي الجديد", "31/البحر الأحمر") '============================================== Kh_Date_Sex_Province = "" On Error GoTo 1 If Len(Trim(MyNumber)) = 0 Then GoTo 1 End If If Not IsNumeric(MyNumber) Or Len(MyNumber) <> 14 Then Kh_Date_Sex_Province = "" GoTo 1 End If If MyTest = 1 Then d = Mid(MyNumber, 6, 2) m = Mid(MyNumber, 4, 2) y = Mid(MyNumber, 2, 2) ty = Left(MyNumber, 1) Select Case ty Case "2": yy = y Case "3": yy = "20" & y Case Else: yy = "" End Select If yy <> "" Then Kh_Date_Sex_Province = DateSerial(yy, m, d) ElseIf MyTest = 2 Then If Left(Right(MyNumber, 2), 1) Mod 2 = 1 Then _ yy = "ذكر" Else yy = "أنثى" Kh_Date_Sex_Province = yy ElseIf MyTest = 3 Then x = Mid(MyNumber, 8, 2) For r = LBound(MyProvinces) To UBound(MyProvinces) xx = MyProvinces(r) If x = xx Then Kh_Date_Sex_Province = Right(MyProvinces(r), Len(MyProvinces(r)) - 3) Exit For End If Next End If 1: End Function كل ما أضفته في الكود هو أكواد باقي المحافظات ، ليكتمل العمل ويستفيد منه الجميع بإذن الله أترككم مع الملف المرفق ، لتتعلموا منه طريقة استخراج البيانات.... دمتم في طاعة الله و السلام هو مسك الختام ID Information.rar

أخي الفاضل الظاهر لدي أن منصب ويندوز 64 بت لديك !! قد تكون المشكلة في ذلك

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

أخي الحبيب يوجد بالردود بعض الأعضاء الذين قاموا مشكورين بتحويل الحلقات إلى ملفات PDF .. يمكنك طباعتها من خلال تلك الملفات

أخي أبو القبطان إحنا ما صدقنا العفريت نام .. عموما .ضع الأسطر التالية بعد السطر الخاص بإلغاء خاصية التنبيه بالرسائل '[Collector]حلقة تكرارية لحذف أوراق العمل ما عدا الورقة المسماة For Each SH In ThisWorkbook.Sheets If SH.Name <> "Collector" Then SH.Delete Next SH الأسطر دي سيتم تنفيذها قبل باقي الأسطر بحيث تحذف كل أوراق العمل ما عدا الورقة المسماة Collector .. تجنياً لتكرار أوراق العمل

الأخ الحبيب جدو الغالي المربع في قلوبنا أبو القبطان مشكور على مرورك العطر بالموضوع .. عايز أقولك : بيقولوا على السواقين عفاريت الأسفلت ، إحنا بقا عفاريت الإكسيل (هنعصر الإكسيل نطلع منه عفاريت صغيرين) الأخ الغالي ياسر البنا الله يبارك فيك ، وبعدين لا علامة ولا حتى حصلت أستاذ أنا يدوب مجتهد بحاول أجيب كل ما هو جديد ومفيد الأخ الحبيب مختار .. حلوة YASSERSAT دي .. جديدة وأنا بحب الجديد دايما ..عموما ممكن نفكر في الموضوع ، بس همتك معايا ، عايزين يكون قمر صناعي ولا القمر في ليلة التمام ..فاهمني يا همام مشكور إخواني على مروركم العطر ..بارك الله فيكم

جرب الملف المرفق التالي Data Validation.rar

الأخ الحبيب شوقي ربيع بارك الله فيك وجزاك الله كل خير على المساندة الكبيرة .. لم أرى مشاركتك إلا الآن .. بصراحة من بدري وأنا مشغول مع العفريت ، وعملت موضوع جديد على هذا الرابط قبل أن أرى مشاركتك http://www.officena.net/ib/index.php?showtopic=59815 بس مش مشكلة زيادة الخير خيرين .. خلي العفاريت يرتاحوا من التنطيط

السلام عليكم ورحمة الله وبركاته إخواني الأحباب ... سبق أن تناولت في موضوع سابق (الانشطار الكبير .. انشطار أوراق العمل بالمنصف إلى مصنفات مختلفة) في هذا الرابط http://www.officena.net/ib/index.php?showtopic=59788 ثم عقب الأخ أبو إيمان (اللي حضر عفريت يصرفه) ، فكان لازم زي ما فركشت أوراق العمل إلى مصنفات ، كان لازم أبحث عن طريقة أرجع بيها اللي اتفركش .. وأصرف العفريت ، عشان ميأذيش حد بالمنتدى المهم .. اليوم معانا الكود الذي يقوم بذلك ، يقوم الكود بالدخول إلى مسار تم تحديده مسبقاً ، وفي داخل المسار (أنا وضعت المصنفات داخل مجلد باسم Test) ، فيقوم الكود بفتح كل مصنف من المصنفات الموجودة ، ثم يدور في حلقة تكرارية لأوراق العمل داخل المصنف الواحد ، ثم ينسخها ، ويضعها بالمصنف الذي يحوي الكود ..) الكود مشروح كالسابق .. سطر بسطر : Sub CollectWorkbooks() 'تعريف المتغير من النوع نصي Dim Path As String 'تعريف المتغير من النوع نصي Dim Filename As String 'تعريف المتغير من النوع ورقة عمل Dim SH As Worksheet 'تعريف المتغير للترتيب الصحيح لأوراق العمل Dim X As Long 'تعيين القيمة 1 للمتغير كبداية X = 1 'تعيين المتغير ليساوي مسار المجلد الذي يحوي المصنفات المراد دمج أوراق العمل منها Path = ThisWorkbook.Path & "\Test\" 'تعيين المتغير ليساوي اسم كل مصنف من المصنفات التي سيتم التعامل معها Filename = Dir(Path & "*.xlsm") 'إلغاء خاصية اهتزاز الشاشة Application.ScreenUpdating = False 'إلغاء خاصية التنبيه بالرسائل Application.DisplayAlerts = False 'حلقة تكرارية للمصنفات الموجودة في المسار المحدد إلى أن لا يجد أي مصنف بالمسار Do While Filename <> "" 'فتح المصنف Workbooks.Open Filename:=Path & Filename, ReadOnly:=True 'حلقة تكرارية لكل أوراق العمل داخل المصنف النشط For Each SH In ActiveWorkbook.Sheets 'نسخ ورقة العمل ولصقها بنهاية فهرس أوراق العمل SH.Copy After:=ThisWorkbook.Sheets(X) 'زيادة قيمة المتغير بمقدار 1 X = X + 1 'الانتقال لورقة العمل التالية Next SH 'إغلاق المصنف Workbooks(Filename).Close 'إعادة ضبط المتغير Filename = Dir() Loop 'تنشيط أو تحديد ورقة العمل الأولى Sheets("Collector").Activate 'تفعيل خاصية التنبيه بالرسائل Application.DisplayAlerts = True 'تفعيل خاصية اهتزاز الشاشة Application.ScreenUpdating = True End Sub بعد فك الضغط عن الملف المرفق ، ستجدون المصنف المسمى Collect Workbooks ...ومجلد باسم Test يحوي المصنفات التي سيتم دمجها .. قم بفتح المصنف Collect Workbooks ثم انقر زر الأمر RUN ليقوم الكود بعملية الدمج لكل أوراق العمل بكل المصنفات الموجودة داخل المجلد Test دمتم في رعاية الله وطاعته حمل الملف من هنا كان معكم أخوكم أبو البراء من منتدى أوفيسنا

جربت الملف وتظهر الدوائر بشكل منضبط لدي .. وتظهر على القيم التي أقل من 5 فقط

جرب الكود بهذه الإضافة البسيطة Sub AddRedCircle() Dim c As Range Dim ws As Worksheet Dim Shp As Shape Set ws = ActiveSheet For Each c In Range("f27:k38") If c.Value < 5 And Not IsEmpty(c.Value) Then c.Select Set Shp = ws.Shapes.AddShape(msoShapeOval, c.Left, c.Top, c.Width, c.Height) With Shp .Fill.Visible = msoFalse .Line.ForeColor.RGB = RGB(255, 0, 0) .Line.Weight = 2 End With End If Next c End Sub Sub DeleteRedCircles() Dim Shp As Shape For Each Shp In ActiveSheet.Shapes If Not (Shp.Type = msoOLEControlObject Or Shp.Type = msoFormControl) Then Shp.Delete Next Shp End Sub

أخي الحبيب محمد طاهر .. رغم وجودي بالمنتدى منذ فترة طويلة .. هذه أول مرة أطلع على هذا القسم عموماً ما أطمح إليه هو ملف كبير وضخم يضم أكواد من هنا وهناك ..كالذي على هذا الرابط http://www.officena.net/ib/index.php?showtopic=57935&hl= قم بالإطلاع على آخر المشاركات ..لترى آخر إصدار من مكتبة الصرح ، وفي انتظار ابداء رأيك بشأن هذه المكتبة ..

استخدم الفاصلة المنقوطة بدلا من الفاصلة ; بدلا من ,