نجوم المشاركات

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

السلام عليكم جميعا.. إليكم طريقة إلغاء الزر الأيمن لكائن المستعرض بأبسط طريقة من داخل أكسس! 1- الخطوة الأولي اضف المكتبة الخاصة بمستندات HTML من مكتة المراجع ( Microsoft Html Object Library ) 2- افتح محرر الشفرة للنوذج وأضف الإعلان التالي في رأس المحرر.. (WithEvents) تنشئ أحداثا خاصة للغرض المعلن عنه! Public WithEvents HTML As HTMLDocument 3- من القائمة المنسدلة اليسرى في أعلى المحرر: اختر الغرض (HTML) الذي سبق الإعلان عنه 4- من القائمة المنسدلة اليمنى: اختر الحدث (oncontextmenu) هذا الحدث يعيد قيمة منطقية (TRUE, FALSE).. اسند القيمة (FALSE) لهذا الحدث كالتالي Private Function HTML_oncontextmenu() As Boolean HTML_oncontextmenu = False End Function 5- في حدث (onload) للنموذج: أضف السطرين التاليين.. [قم بتبديل ما يلزم] Private Sub Form_Load() Me.WebBrowser0.Navigate "ABOUT:BLANK" Set HTML = Me.WebBrowser0.Document End Sub هذا كل شي.. إليكم المثال web_browser.zip

هلا والله بشفان انا من الكوكب الذي كما قلت عنه: جعفر

شكرا أخوي رمهان ، خليتني افكر بطريقة ثانية بدل الاستعلام ، نستخدم الكود في وحدة نمطية ، ونناديها من الاستعلام هذا الاستعلام ، وننادي الوحدة النمطية هكذا: . والنتيجة: . وهذه هي الوحدة النمطية: Function Lookup_Values(N) 'rsT = Row Source Type 'rs = Row Source rsT = CurrentDb.TableDefs("tabl").Fields("nams").Properties("RowSourceType").Value rs = CurrentDb.TableDefs("tabl").Fields("nams").Properties("RowSource").Value If rsT = "Value List" Then Dim x() As String x = Split(rs, ";") For i = LBound(x) To UBound(x) If x(i) = N Then Lookup_Values = x(i + 1) Lookup_Values = Replace(Lookup_Values, Chr(34), "") Exit For End If Next i End If End Function . ولكن ، الجواب الاساسي كان ولا يزال: جعفر 574.1.NamoerAndTeixt.accdb.zip

جرب فكرة انتقاء القيم بشرط وبما ان القائمة كقائمة قيم نستخدم الدالة choose للمساعدة Expr1: [prise]*[namepr] & " " & Choose([nams],"ملي غرام","كيلو غرام","لتر","جالون") وعليك تغيير قيمة الجالون الى 4 بدلا من 5 بالتوفيق

اليك هذا في حدث عند فتح النموذج اكتب هذا Private Sub Form_Open(Cancel As Integer) Me.KeyPreview = True End Sub وفي حدث عند الضغط الازرار اكتب هذا Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = 49 Then MsgBox "مرحبا" End If End Sub واضغط على مفتاح شيفت مع رقم واحد راح يظهر مسج بوكس بيقولك مرحبا وتكدر بدل مسج بوكس تنطي اي كود فيها 48 = 0 49 = 1 50 = 2 51 = 3 52 = 4 53 = 5 54 = 6 55 = 7 56 = 8 57 = 9

السلام عليكم اخوتي في الله عايزين نبدء مشاركة لكل الاعضاء واللي عنده معلومة يشارك بيها من حيث بناء قاعدة بيانات مبيعات ومشتريات ومن حيث التعلم واخذ فكرة عن انشاء عمل كمثل هذا انا واحد من الناس قمت بانشاء عديد من البرامج ولكن عجزت امام انشاء قاعدة بيانات مبيعات ومشتريات انا بصراحة في الاول كنت افتكرها سهلة وكان عندي بعض المعلومات عنها لكن بطرحي سؤال في المنتدي الغالي اوفيسنا اتضحلي ان كل المعلومات اللي عندي لانشاء قاعدة البيانات خطأ وبالتحدث مع الاستاذ الفاضل رضوان ( rudwan ) لقيت ناقصني كتير وانه فيه جداول كنت متخيل انها مش ضرورية في البرنامج لان كان الفكرة في انشاء برنامج بالنسبالي هو شاشة بيع واضافة رصيد للجداول من نفس الشاشة طلبت من الاستاذ رضوان بانشاء موضوع جديد لعمل قاعدة بيانات مبيعات ومشتريات ومشاركة كل واحد من الاعضاء ولو بفكرة عشان نقدر نوصل لنتيجة كويسة الفكرة من انشاء قاعدة البيانات هي ان اللي مش عارف يتعلم وياخد فكرة عن المشروع ولو حب ينفذه يلاقي حاجة تساعه في العمل انا قمت بعمل بعض الجداول واللي شايف ان فيه جداول المفروض تكون موجودة يقدر يضفها ويرفق الملف توكلنا علي الله مبيعات ومشتريات.rar

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

هذا بالتأكيد على حد علمى. اليك هذا المثال العملاق كصاحبه وبه شرح ومثال https://www.google.com/url?q=https://www.officena.net/ib/topic/60235-%D9%87%D8%AF%D9%8A%D8%A9-%D8%B1%D8%A8%D8%B7-%D8%A7%D9%84%D8%B5%D9%88%D8%B1-%D9%88%D9%85%D9%84%D9%81%D8%A7%D8%AA-pdf-%D8%A8%D8%A7%D9%84%D9%86%D9%85%D9%88%D8%B0%D8%AC%D8%8C-%D9%88%D8%AA%D8%B4%D8%BA%D9%8A%D9%84-%D8%A7%D9%84%D9%85%D8%A7%D8%B3%D8%AD-%D8%A7%D9%84%D8%B6%D9%88%D8%A6%D9%8A/&sa=U&ved=0ahUKEwj53_if94jSAhXhd5oKHfOFAA4QFggFMAA&client=internal-uds-cse&usg=AFQjCNHbxJA4PZBUuJBUSOx6yYossFq4QA أقصد تاريخ البدأ بالجدول لا تاريخ البدأ بالنموذج لاحظى الصورة جيدا الجدول بالخلف بالصف الذى به رقم الموظف 222 به تاريخ انتهاء 11/11/2016 وليس به تاريخ ابتداء تمنياتى بالتوفيق

المرفق في الرابط اعلاه بصيغة accdb والمتوافق مع اكسس 2007 ، وارفق لك نسخة اخرى بصيغة mdb جعفر 569.Database1.mdb.zip هذا صحيح اخوي رمهان ، ولكن كود التعطيل يكون جزء من كود الصفحة ، بينما نحن نتعامل مع كود من خارج الصفحة للتحكم بالصفحة ، وكما تعرف ، بأن المتصفح داخل الاكسس لا يملك جميع ميزات وعمل المتصفح الاصل IE ، فلربما تكون هذه الميزة محذوفه منه!! جعفر

أعتقد أنه طالما سندخل البيانات من نموذج بشروط معينة للحفظ فمن الأفضل أن لا يكون الفورم مرتبط هذه واحدة والثانية وجود المرفقات داخل قاعدة البيانات - مما يقصر العمر , عمر القاعدة يعنى - وسوف يؤدى لتضخمها بشكل كبير جدا جدا فى وقت قصير جدا جدا لذا نصيحتى أن تكون المرفقات بفولدر مستقل ويتم حفظ الرابط الخاص بها بالجدول بدلا منها هل وضعت كود فحص الأجازات خلف مربع النص الخاص بالأجازة الزمنية كما هو الحال بالأجازة الاعتيادية - أعتقد أن الجواب لا - جربى التغير وموافتنا بالنتائج. مع ملاحظة تغير مسميات عناصر التحكم داخل الكود لأ الاعتراض لم يكن من أجل تعارض التاريخ لموظف آخر وانما ولا دققنا قليلا بالصورة للاحظنا أن تاريخ البدأ فارغ وهذا مما جعل الكود يبحث فى الفترة ما بين 1/1/1900 وحتى تاريخ الانتهاء المحدد لهذا الموظف. جربى ادخال تاريخ بدأ والمحاولة مجددا.

السلام عليكم تفضل هو تقرير واحد ، وكل شئ معتمد على qry_Temp التي يكون فيها التواريخ كاملة ، والتقرير مصدره qry_T22 ، واستعملت الاستعلام المشروط ، حيث جعلت الايام التي ليس فيها غياب ولا تأخير ، باللون الاصفر: . جعفر 459.3.AbsentLate-10-12-2016.accdb.zip

جزاك الله خيرا أخى - ومكلف نفسك وجيب ورد مكنش له لزوم خالص - يلا نردهالك فى الأفراح

هذا شرف كبير أستاذى العزيز - تهنئتكم أحب الى من الترقية ولكنى كنت أعتقد أن بعد الفضية الذهب وكنت أنتظر الذهبية (طبعا أسعار الذهب مرتفعة فى مصر هذه الأيام - ووسام ذهب كان هيعمل مبلغ كبير - يلا كل شىء نصيب )

أخى واستاذى الفاضل / خالد الرشيدى السلام عليكم ورحمته الله وبركاته بجد والله العظيم وكأنه حلم وقد أرسلك الله تعالى لى لتحقيقه كلمات الشكر قليله أمام هذا المجهود الكبير وهذا الخُلُق المتميز اما عن مشكلة الطباعه ربما سيكون لها موضوع أخر ولكن بعد محاوله أخيره فى العمل بالملف بشكل نهائى فبارك الله فيكم وفى من تحب **** شاكر فضل حضرتك **** وجزاكم الله خيرا

المعادلة في E2 اضفط Ctrl+Shift+Enter ثم اسحب نزولاً =IF(AND(B2:D2=المصروف!D2:F2),"مصروف","غير مصروف")

اخي الكريم بالنسبة لطلب الطباعه فأشهر وأسهل الطرق لتحجيم حجم الصفحه من خلال تنشيط وضع Page Break Preview والسحب واليك الملف --بعد التعديل على الكود -- search+111_2.rar

السلام عليكم انظر النتيجة بالاستعلام هل هى موافقة لمرادك ان كانت نعم حولنا الاستعلام الى تحديث أو الحاق كما تريد ووافنا بالنتائج New تطبيق Microsoft Office Access.rar

وعليكم السلام ورحمة الله قومى بحذف هذا السطر من الكود فلا حاجة له فقد قمت بالتعديل على كود الحفظ ولم يعد لهذا السطر حاجة الآن وكذلك ستجدين هذا السطر فى زر جديد قومى بحذفه أيضا فقد تم تعديل الكود كذلك.

السلام عليكم اخي الكريم زكرت في المطلوب إظهار العمود التاسع وهذا تم / اما وعن الطباعه فلم افهم حضرتك زكرت انه عند تنفيذ الكود تتغير نطاقات الطباعه -- اي كود تقصد -- كيف تقوم بالطباعه -- ارجو مزيد من التوضيح search+111.rar

انا ساشارك بفكرة نضع حدث عند العنصر المستعرض وعند الحدث عند الماوس لاعلى MouseUp نضع الكود التالي if button=2 then sendkeys "{esc}" فعندما يختار امستخدم الماوس الايمن على المستعرض فانه يعرض القامة ولكن بمجرد رفع الماوس تختفي الفكرة الثانية بما ان المستعرض يقبل اوامر الجاقا سكريبت او الفي بي اسكريبت فيمكن استخدام امر اخفاء القائمة المختصره حسب اللغة والله اعلم تحياتي

صحيح أستاذنا جعفر ، وأكيد الخطأ لعدم وجود القيمة NoViewContextMenu لذلك أضفت كود إنشائها في حالة عدم وجودها Database 561.rar

جرب هذا test70.rar

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

وعليكم السلام ورحمته الله وبركاته الاستاذ الفاضل / خالد الرشيدى والله بسم الله ماشاء الله عاشت يمناك وجزاكم الله تعالى عنى خير الجزاء ورزقكم وإيانا من حيث لانحتسب أطمع أخى الكريم فى إظهار العمود التاسع بالليست بوكس لعدم التنويه عن ذلك فرجاء قبول إعتذراى ومعلشى على ماتفرج علينا وأنزل نسخة مش متعربه برجاء جعل خاصية الــ Left to Right بالليست = True كما أرجو من سيادتكم الله يبارك فى عمرك الاطلاع والافاده عما تحتويه الورقه print فيما عدا ذلك فالامور تسرى على مايرام جعلكم الله تعالى عونا للجميع ***** شاكر فضل حضرتك ***** وجزاكم الله خيرا search+111.rar

صع هذه المعادلة قي G20 =COUNTIF(السجل!$C$5:$C$20,$D$14)

السلام عليكم ورحمة الله أخي الكريم، ما فهمتَه صحيح جدا... بارك الله فيك وفي علمك وجزاك الله عني خيرا.... بن علية

السلام عليكم تم تحويل المعادلة المطلوبةإلي كود وهى =COUNTIF(INDEX($C$3:$EV$5000;0;0);$FA3) أعتقد أن الملف الآن مناسب book book4.rar

السلام عليكم ورحمة الله أخي الكريم، تم الاستغناء عن المعادلات في النطاق Q7:Q25 وفي الخلية W1 وعن الكود hben مع التعديل على الكود... بن علية بحث وفهرسة وترحيل مع الطباعة2.rar

السلام عليكم اخي الكريم زكرت في المطلوب انه من خلال زر ادخال او DblClick يتم ادخال بيانات الصنف بالصف المحدد له بالوقه Search دون تحديد اى صف تقصد عموما جرب الملف التالى علة المطلوب -- الى اول صف فارغ --- search.rar

ضع نجمه قبل الاسم المراد البحث عنه

بارك الله فيك أخي الغالي زيزو .. كود رائع وممتاز باستخدام المصفوفات بالرغم من أنه يمكن حل المشكلة باستخدام الفلترة ثم نسخ الصفوف الظاهرة فقط أو باستخدام التصفية المتقدمة Advanced Filter ولكني أعشق التعامل مع المصفوفات فقمت بنسخ كودك الرائع وتحويله لإجراء عام يمكن الاعتماد عليه بشكل عام .. حيث يمكن التغيير في 6 أسطر كما هو موضح في التعليقات المصاحبة للكود ... بعدها يمكن تنفيذ الكود بسهولة Sub Test() Dim wsSource As Worksheet Dim wsTarget As Worksheet Dim rng As Range Dim rn As Range Dim colCr As Long Dim str As String Set wsSource = Sheets("Sheet1") 'Source Sheet Set wsTarget = Sheets("Sheet2") 'Target Sheet Set rng = wsSource.Range("A3:E" & wsSource.Cells(Rows.Count, 1).End(xlUp).Row) 'Data Range Set rn = wsTarget.Range("A4") 'Results Range colCr = 5 'Criteria Column str = wsSource.Range("E1").Value 'Criteria String TransferDataUsingArrays wsSource, wsTarget, rng, rn, colCr, str End Sub Sub TransferDataUsingArrays(sSheet As Worksheet, tSheet As Worksheet, sRange As Range, tRange As Range, colCrit As Long, strCrit As String) Dim arr As Variant Dim temp As Variant Dim p As Long Dim i As Long Dim j As Long Dim x As Long Application.ScreenUpdating = False With tSheet With .Range(.Cells(tRange.Row, tRange.Column), .Cells(Rows.Count, sRange.Columns.Count)) .ClearContents .Font.Bold = False .Font.ColorIndex = xlAutomatic .Interior.Color = xlNone .Borders.LineStyle = False End With With .Cells(tRange.Row, tRange.Column).Resize(, sRange.Columns.Count) .Value = sSheet.Cells(sRange.Row, sRange.Column).Resize(, sRange.Columns.Count).Value .Font.Bold = True .Font.Color = vbRed .Interior.Color = vbCyan End With End With arr = sRange.Value ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2)) For i = 2 To UBound(arr, 1) If arr(i, colCrit) Like "*" & strCrit & "*" Then p = p + 1 For j = 1 To UBound(arr, 2) temp(p, j) = arr(i, j) Next j End If Next i If p > 0 Then tRange.Offset(1).Resize(p, UBound(temp, 2)).Value = temp tRange.Resize(p + 1, UBound(temp, 2)).Borders.LineStyle = True For i = sRange.Column To sRange.Columns.Count tRange.Offset(, 0 + x).ColumnWidth = sSheet.Columns(i).ColumnWidth x = x + 1 Next i Application.ScreenUpdating = True End Sub

رائع أخي الغالي أبو عيد (معادلة في منتهى الروعة والإبداع) لتحويل المعادلة لكود يمكن ببساطة استخدام كلمة Formula للنطاق المطلوب ووضع المعادلة مع تغييرات بسيطة اطلع على الكود التالي وتعلم كيف يمكن تحويل المعادلة إلى كود Sub Test() With ActiveSheet .Range("BN4:BN8").Formula = "=IFERROR(IF(OR(BM4="""",L4="""",L4=""1"",L4=""OFF""),"""",CHOOSE(L4,"""",""خطأ"",BM4+366,""خطأ"",BM4+545,""خطأ"",BM4+730)),"""")" .Range("BO4:BO8").Formula = "=IFERROR(IF(OR(BM4="""",L4="""",L4=""1"",L4=""OFF""),"""",CHOOSE(L4,"""",""خطأ"",BM4+545,""خطأ"",BM4+730,""خطأ"",BM4+910)),"""")" .Range("BN4:BO8").Value = .Range("BN4:BO8").Value End With End Sub

السلام عليكم ورحمة الله جرب هذا الملف واخبرنى بالنتيجة test.rar

وعليكم السلام حيا الله اخوي كاسر حسب علمي ، لا تستطيع الحصول على قيمة العمود/الاعمدة الآخرى من حقل في جدول فيه قيم عن طريق Lookup ، لذا يجب فصل هذه القيم في جدول مستقل ، ثم ربط الجدولين بهذا الحقل ، وعرض النتائج المطلوبة هذه احد الاسباب التي لا يُنصح بإستخدام Lookup في الجداول جعفر 574.NamoerAndTeixt.accdb.zip

عفوا ما كنت فاهم هذه النقطة

وعليكم السلام اعمل في جدولك حقلين ، حقل به الكلمات بالتشكيلة ، وحقل آخر للكلمات بدون تشكيلة ، في النموذج ، اعمل الحقل بدون تشكيله مخفي ، وفي الحدث بعد التحديث لحقل التشكيلة ، استخدم هذه الوحدة النمطية لإزالة التشكيلة ، وحفظ النتيجة في الحقل الآخر. الآن وقد اصبح لديك حقل بدون تشكيلة ، فإعمل البحث فيه (لا تنسى انه سيكون مخفي) ، ونتيجة البحث اجعلها تُعرض في حقل التشكيلة وهذه هي الوحدة النمطية ، وغيّر فيها كيف شئت (وللأسف ، لأن الكلمات بالعربية ، فدالة Replace عكست اماكن الخانات كما ترى ، ولكن الكود يعمل بطريقة صحيحة): Function Simplify(CW) On Error GoTo err_Simplify 'CW = Correct Word ' when we want to search, we write in simple words, ' simple words = words without hamza for example, ' so we want to avoid these letters ' If Left(CW, 2) = "وَ" Then CW = Replace(CW, "وَ", "") ' If Left(CW, 2) = "فَ" Then CW = Replace(CW, "فَ", "") ' CW = Replace(CW, "وَ", "") ' CW = Replace(CW, "وَ", "") CW = Replace(CW, "آ", "ا") CW = Replace(CW, "أ", "ا") ' CW = Replace(CW, "ؤ", "ا") ' CW = Replace(CW, "ؤ", "ء") CW = Replace(CW, "إ", "ا") ' CW = Replace(CW, "ئ", "ا") ' CW = Replace(CW, "ئ", "ء") ' CW = Replace(CW, "ى", "ا") 'CW = Replace(CW, "ة", "ه") CW = Replace(CW, "ّ", "") CW = Replace(CW, "ـ", "") CW = Replace(CW, "ً", "") CW = Replace(CW, "ٌ", "") CW = Replace(CW, "ٍ", "") CW = Replace(CW, "ُ", "") CW = Replace(CW, "ِ", "") CW = Replace(CW, "ْ", "") CW = Replace(CW, "َ", "") CW = Replace(CW, " ", "") CW = Replace(CW, "!", "") CW = Replace(CW, " ", "") CW = Replace(CW, "ٌ", "") CW = Replace(CW, " ", "") CW = Replace(CW, ".", " ") CW = Replace(CW, "-", " ") CW = Replace(CW, "[", " ") CW = Replace(CW, "]", " ") CW = Replace(CW, "(", " ") CW = Replace(CW, ")", " ") CW = Replace(CW, ",", " ") CW = Replace(CW, "_", " ") CW = Replace(CW, "¬", " ") CW = Replace(CW, ":", " ") CW = Replace(CW, "؛", " ") CW = Replace(CW, ".", " ") CW = Replace(CW, "،", " ") CW = Replace(CW, "«", " ") CW = Replace(CW, "»", " ") CW = Replace(CW, "{", " ") CW = Replace(CW, "}", " ") CW = Replace(CW, "§", " ") CW = Replace(CW, "ـ", " ") CW = Replace(CW, "1", " ") CW = Replace(CW, "2", " ") CW = Replace(CW, "3", " ") CW = Replace(CW, "4", " ") CW = Replace(CW, "5", " ") CW = Replace(CW, "6", " ") CW = Replace(CW, "7", " ") CW = Replace(CW, "8", " ") CW = Replace(CW, "9", " ") CW = Replace(CW, "0", " ") CW = Replace(CW, "~", " ") CW = Replace(CW, CrLf, " ") CW = Replace(CW, Lf, " ") CW = Replace(CW, Cr, " ") CW = Replace(CW, "*", " ") CW = Replace(CW, "؟", " ") CW = Replace(CW, "؛", " ") CW = Replace(CW, Chr(34), " ") CW = Replace(CW, "*", " ") CW = Replace(CW, "؟", " ") ' CW = Replace(CW, "؛", " ") ' CW = Replace(CW, "؛", " ") Simplify = CW Exit Function err_Simplify: If Err.Number = 94 Then 'null Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Function جعفر

ربما كان المطلوب الفواتير salim.rar

جزاك الله خيرا أخي رجوعي للأسف سيظل قليلا ومتباعدا لإنشغالي الشديد وأرجو من الله أن أجد بعض الدقائق لمشاركتكم أحبائي فهذا والله يسعدني أكثر مما يسعدكم

في حقل تاريخ تكدر تعمل شرط بين تاريخين اي يعني Between [tarix1] And [tarix2]

السلام عليكم طبعا الأساتذة الأفاضل اللي سبقوني في الإجابة هم كيان نتعلم منهم ما شاء الله تبارك الله.. أفكار جبارة وحلول مدهشة ولكن رغبتي في التعلم ومشاركتكم التجربة التي ستعود بكل تأكيد علي بالفائدة أحببت أشارككم هذه الطريقة للحل طبعا على شان أوصل للحل بطريقة سهلة سميت الأعمدة كل عمود باسم تابع للجدول .. مثلا عمود التاريخ في شيت القاهرة سميته DateCairo وفي الشيت الثاني سميته DateAlex. وهكذا لبقية الأعمدة وأشكركم لإتاحة مثل هذه الفرص لنزداد علما وخبرة تحياتي لكم تدريب_2.rar

ولااروع .. سهولة في التطبيق .. سرعه في التنفيذ كود استدعاء للمبدع ياسر العربي Sub ALL() ''هذا الكود للعبقري ياسر العربي حفظه الله '' تم هذا الكود بتاريخ 8 / 10/ 2016 ''الهدف من الكود هو استدعاء البيانات ''شرح الكود ''متغيرات Dim myArray, lr, X, targt, targt1, targt2, targtN Dim SERCH As Worksheet, _ DATA As Worksheet '____________________________________________ 'اسم شيت قاعدة البيانات Set DATA = Worksheets("رصد الترم الثانى") 'اسم الشيت الخاص بالبحث Set SERCH = Worksheets("كشوف الطلبه") '____________________________________________ 'المدى الذي سيتم مسحه في صفحه الهدف Range("D10:AB1000").Clear 'المدى الذي سيتم نسخه لعدد محدد بخليه محدده Range("C9:AB9").AutoFill _ Destination:=Range("C9:AB" & _ Range("B4").Value + 8), Type:=xlFillDefault 'اخر صف به بيانات lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row + 2 'مدى صفحة الهدف وهو يبدأ بعد عمود المسلسل 'والرقم الموجود هو رقم عمود البدايه ' 'مسح نطاق البحث القديم SERCH.Range("D9:AB" & SERCH.Cells(Rows.Count, 4) _ .End(xlUp).Row + 1).ClearContents 'معيارين البحث ' targt2 = targt targt = "له* دور ثان في" targt2 = "ناجح" 'نطاق قاعدةالبيانات ' صفحة المصدرالذي سيتم البحث فيه myArray = DATA.Range("A7:FF" & lr) '____________________________________________ ReDim Y(1 To UBound(myArray, 1), 1 To _ UBound(myArray, 2)) For X = LBound(myArray) To _ UBound(myArray) If targt = "" Then Exit Sub 'هنا التعديل للمعيارين If myArray(X, 101) Like targt & "*" _ Or myArray(X, 101) Like targt2 & _ "*" Then rw = rw + 1 'متغير ارقام 'الاعمده المطلوب الاستدعاء منها 'العمود التاني بعد المسلسل Y(rw, 1) = myArray(X, 2) 'العمود الثالث بعد المسلسل Y(rw, 2) = myArray(X, 3) 'العمود الرابع بعد المسلسل Y(rw, 3) = myArray(X, 13) 'العمود الخامس بعد المسلسل Y(rw, 4) = myArray(X, 22) 'العمود السادس بعد المسلسل وهكذا Y(rw, 5) = myArray(X, 31) Y(rw, 6) = myArray(X, 40) Y(rw, 7) = myArray(X, 51) Y(rw, 8) = myArray(X, 52) Y(rw, 9) = myArray(X, 82) Y(rw, 10) = myArray(X, 101) Y(rw, 11) = myArray(X, 102) ' Y(rw, 12) = myArray(X, 110) ' Y(rw, 13) = myArray(X, 111) End If Next X If rw > 0 Then SERCH.Cells(Rows.Count, 4).End(xlUp)(2, 1).Resize(rw, 13).Value = Y() End Sub الاستدعاء بطريقه ( خليفه عبد الله باقشير ) الاستاذ ياسر.rar

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

كيف تمنحه اجازة لسنة قادمة ؟ !! ايضا لا تضاف كاملة بدخول السنة الجديدة ، لانه لا يستحقها كاملة وانما يستحق اجازة مقابل الايام التي عملها خلال هذه السنة امل ان الفكرة واضحة لك كامل الاستحقاق يحتسب : من تاريخ بداية العقد الى تاريخ اليوم الحالي باعتبار استحقاقه الشهري من الايام هو ( 4.16 ) يوم فيصبح استحقاق السنة حوالي 50 يوما كما هو معمول به في بلدك بينما في بلدي الاستحقاق هو (3.75 ) يوم عن كل شهر فيستحق يوما اجازة مقابل 8 ايام عمل و 45 يوما خلال السنة

حسب ترتيبها في مصدر البيانات اي في الاستعلام

عملت لك حقل واحد و باقي الحقول عليك ( بنفس الطريقة ) ... قائمة منسدلة 2.rar

السلام عليكم جرب المرفق التالى علة المطلوب إظهار باقي الكمية.rar

السلام عليكم جرب أخى هذا الكود يقوم بالترحيل مع انشاء الصفحات مع نسخ التنسيقات لعله يكون كما يريد Sub ragab() Dim cl As Range, sh As Worksheet Application.ScreenUpdating = False For Each sh In ThisWorkbook.Worksheets If Not sh.Name = "البيانات" Then sh.Range("A1:J1000").ClearContents End If Next LR1 = Cells(Rows.Count, 6).End(xlUp).Row LR2 = Cells(Rows.Count, 8).End(xlUp).Row Set Rng1 = Range("F2:F" & LR1) Set Rng2 = Range("H2:H" & LR2) Set Rng = Union(Rng1, Rng2) For Each cl In Rng x = Trim(cl.Value) On Error Resume Next If Worksheets(x) Is Nothing Then Sheets.Add.Name = x Sheets(x).Move After:=Sheets(Sheets.Count) End If Sheets("البيانات").Range("A1:J1").Copy Sheets(x).Range("A1").PasteSpecial xlPasteValues Sheets(x).Range("A1").PasteSpecial xlPasteFormats Sheets("البيانات").Cells(cl.Row, 1).Resize(1, 10).Copy Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial xlPasteValues Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row, 1).PasteSpecial xlPasteFormats Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row, 1).PasteSpecial xlPasteColumnWidths Application.CutCopyMode = False Next MsgBox "تم الترحيل بنجاح الى صفحات منفصلة" Sheets("البيانات").Select Application.ScreenUpdating = False End Sub 2متابعة .rar

تحويل فروق التاريخ والوقت لنص ... طرق و أفكار ... NA_ConvertDateTimeToFormattedString.rar