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

السلام عليكم، كثيراً ما ارى طلبات "كيفية عمل صلاحيات المستخدمين" قمت بعمل مثال بطريقة مبسطة جدا لكيفية عمل هذه الصلاحيات في تحديد فتح النماذج لمن لا يعرف ماذا اقصد بصلاحيات المستخدمين, مثال: اليوزر A غير مسموح له بفتح فورم الاعدادات مثلاً، اما اليوزر B مسموح له بفتح فورم الاعدادات اي سؤال انا موجود. تحياتي لكم Permission.accdb

تفضل ::::: وهذ هو الكود الذي تحدث عنه أخي @ mohamedd2003 On Error Resume Next Langauge ELanguage.Ar Dim fOK As Boolean Dim strTemp As String Forms!whatsapp.SetFocus strTemp = Me.txtMessage fOK = SetClipboardData_clt(strTemp) '========================================================================================================= Langauge ELanguage.en Application.FollowHyperlink "https://wa.me/" & txtNumbers auseTime = 40 start = Timer Do While Timer < start + auseTime DoEvents Loop Call SendKeys("~", True) Call SendKeys("{Enter}", True) Call SendKeys("^v", True) Call SendKeys("{Enter}", True) '=========================================================================================================== MsgBox "تم الارسال للرقم المطلوب"

السلام عليكم ورحمة الله وبركاته تفضل اخوي العزيز .. امكانية حذف البيانات الموجودة في DataEntry .. في الخلية W الى AK .. الا اذا انته تستخدمها في مكان اخر .. تم تغيير اسم الصفحة الى Report .. تم اضافة عدد الطلاب من ضمن الجدول الاساسي في العامود R .. All Subjects2 .xlsb

جرب هذا اذا New Microsoft Access 11111.accdb

وعليكم السلام ورحمة الله وبركاته هذه هي Datediff("m",OldDate,NewDate) '"m" = months '"yyyy" = years '"dd" = daies أما عن هذه فلم أفهم ما المقصود بالشهر الأخير هل تعني التاريخ الأحدث أم الأقدم الذي تريد زيادته الي 1

لصعوبة كشف كلمة المرور والبيانات المهمة من قبل المتطفلين.

حسنا، لا مشكلة مع انني شرحت الاكواد داخل البرنامج Public Function XOREncryption(CodeKey As String, DataIn As String) As String خوارزمية تشفير النصوص يطلب براميترات اثنان الاول هو مفتاح التشفير ( CodeKey As String ) وهو المتمثل هنا Function KEY_ENDE() KEY_ENDE = "PA$X" End Function والبراميتر الثاني ( DataIn As String ) النص المراد تشفيرة نفس الكلام ينطبق على فنكشن فك التشفير Public Function XORDecryption(CodeKey As String, DataIn As String) As String الفنكشن هذا Public Function GetUsernameLogin() As String يقوم بجلب اسم المستخدم الحالي لقاعدة البيانات من جدول AutoSave ويقوم بفك تشفيرة وارجاعه كـ نص عادي لكي يتم مطابقتة فيما بعد اما هذا الفنكشن Public Function CheckPermissions(Username As String, permissions As String) As Boolean يحتاج براميترات اثنان الاول اسم المستخدم لقاعدة البيانات والثاني الصلاحية المطلوبة لكي يتم تدقيقها هل هي True أو False هل مسموح له بعمل هذا الاجراء او لا، نمرر البراميتر الأول وهو الـ Username من الفنكشن التالي GetUsernameLogin ثم نمرر البراميتر الثاني وهو حسب ما مكتوب في الجدول وحسب الفورم المطلوب فتحه مثلا: لدي في الجدول حقل اسمه frm_setting واريد ان اتحقق هل اليوزر لديه صلاحية بفتح هذا الفورم فأكتب: If CheckPermissions(GetUsernameLogin, "frm_setting") = False Then MsgBox "You do not have permissions !", vbCritical, "ERROR!" Exit Sub End If وسلامتك. نعم، ممكن ذلك. عندما اجد وقت كافي سأقوم بعمل مثال لك.

احسنت، طريقة جميلة اغنت رصيدي المعرفي.

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم الحساب عن طريق الجمع التركمي Expr1: Nz(DSum("nz(ts)";"Table1";"[N°]<=" & [N°] & " and nom='" & [nom] & "'" & " and Designation='" & [Designation] & "'");0) test.rar تحياتي

هل تعلم ما هي أحب الأعمال إلى الله؟ أحب الأعمال إلى الله تعالى هي كما بينها نبينا المصطفى صلوات الله وسلامه عليه وهي الصلاة على وقتها ثم بر الوالدين ثم الجهاد في سبيل الله. أي الأعمال أحب إلى الله عز وجل؟ هذا السؤال يبين الهمة العارمة كهمة الصحابة الكرام رضي الله عنهم أجمعين، عملوا وجدوا واجتهدوا ثم صارو يسألون عن أفضل الأعمال للتقرب إلى الله. ذكر الإمام البخاري في كتاب صحيح الأدب المفرد عن عبدالله ابن مسعود أنه قال: سَأَلْتُ النبيَّ ﷺ أيُّ العمَلِ أحبُّ إلى اللهِ عزَّ وجلَ؟ قال: (الصَّلاةُ علَى وقتِها)، قُلتُ: ثمَّ أيُّ؟ قال: (ثمَّ بِرُّ الوالديْنِ) قلتُ: ثمَّ أيُّ؟ قال: (ثمَّ الجهادُ في سبيلِ اللهِ)، قال: حدَّثَني بِهِنَّ، ولَو استزدتُه لزادَني. الأعمال الصالحة كلها يحبها الله، لكن فيها أحب، فسؤال ابن مسعود أي العمل أحب إلى الله؟ يعني يريد أن يلتزم الأحب الأعلى، وهذا دلالة على همة عارمة وعلى استعداد كبير للقاء رب العالمين سبحانه وتعالى. 1- الصلاة على وقتها أفضل الأعمال وأحبها إلى الله تعالى هي الصلاة على وقتها، يعني في أفضل أوقاتها، وأفضل الأوقات للصلوات تختلف حسب كل صلاة. 2- بر الوالدين من أفضل الأعمال الصالحة بعد الصلاة هو بر الوالدين، فالصلاة توحيد الله وطاعته وحقه على العباد، ثم يأتي بعد ذلك بر الوالدين وحقوقهم بعد حق الله تعالى. وبهذا جاء القرآن: ﴿وَقَضَىٰ رَبُّكَ أَلَّا تَعْبُدُوا إِلَّا إِيَّاهُ وَبِالْوَالِدَيْنِ إِحْسَانًا ۚ﴾، ﴿أَنِ اشْكُرْ لِي وَلِوَالِدَيْكَ إِلَيَّ الْمَصِيرُ﴾، ﴿وَاعْبُدُوا اللَّهَ وَلَا تُشْرِكُوا بِهِ شَيْئًا ۖ وَبِالْوَالِدَيْنِ إِحْسَانًا﴾، دائماً حق الله يأتي أولاً ثم يأتي بعد ذلك حق الوالدين. من أفضل الأعمال الصالحة بعد الصلاة هو بر الوالدين، فالصلاة توحيد الله وطاعته وحقه على العباد، ثم يأتي بعد ذلك بر الوالدين وحقوقهم بعد حق الله تعالى. وبهذا جاء القرآن: ﴿وَقَضَىٰ رَبُّكَ أَلَّا تَعْبُدُوا إِلَّا إِيَّاهُ وَبِالْوَالِدَيْنِ إِحْسَانًا ۚ﴾، ﴿أَنِ اشْكُرْ لِي وَلِوَالِدَيْكَ إِلَيَّ الْمَصِيرُ﴾، ﴿وَاعْبُدُوا اللَّهَ وَلَا تُشْرِكُوا بِهِ شَيْئًا ۖ وَبِالْوَالِدَيْنِ إِحْسَانًا﴾، دائماً حق الله يأتي أولاً ثم يأتي بعد ذلك حق الوالدين. رضا الله تعالى في رضا الوالدين وسخط الله تعالى في سخط الوالدين، وفي هذا إشارة إلى عظيم قدر الوالدين عند الله تعالى حيث أنه سبحانه ضمن رضاه رضاهما وضمن سخطه سخطهما. فطوبى ثم طوبى ثم طوبى لمن فاز في دنياه برضا والديه، والويل كل الويل لمن خرج من الدنيا بسخط والديه، إذا رضيا رضي الله، وإذا سخطا سخط الله رب العالمين. لذلك من هنا نصيحة للشباب احرص على طاعة أبويك ما دامت الطاعة في طاعة الله، أما إن أمراك بمعصية الله فلا طاعة لمخلوق في معصية الخالق. لكن ما كان أمرهما يوافق طاعة الله فالزم طاعتهما تدخل الجنة من أقرب طرقها وأقصرها. وإياك ثم إياك ثم إياك أن تقع في العقوق لأن العقوق جاء قرين الشرك بالله، والشرك بالله ليس له مجال إلا النار والعار. 3- الجهاد في سبيل الله من أحب الأعمال إلى الله الجهاد في سبيل الله، وهو أنزل في الأجر من رعاية الأبوين، أنزل في الأجر من الإحسان إلى الوالدين. وسبق أن بينا قبل ذلك في لقاءات شتى أن الإنسان إذا استشهد في سبيل الله فالشهادة تنجيه من النار، ولكن إذا خرج بدون إذن أبويه هو بهذا قد عق أبواه. شهادته وموته في سبيل الله طاعة عظيمة جداً نجته من النار، لكنه خرج وقد عق أبويه فمنعه العقوق من دخول الجنة، ومن ثم يحبس على الأعراف. والله تعالى ذكر القول وفصله في سورة الأعراف: ﴿وَبَيْنَهُمَا حِجَابٌ ۚ وَعَلَى الْأَعْرَافِ رِجَالٌ يَعْرِفُونَ كُلًّا بِسِيمَاهُمْ ۚ وَنَادَوْا أَصْحَابَ الْجَنَّةِ أَن سَلَامٌ عَلَيْكُمْ ۚ لَمْ يَدْخُلُوهَا وَهُمْ يَطْمَعُونَ (46) ۞ وَإِذَا صُرِفَتْ أَبْصَارُهُمْ تِلْقَاءَ أَصْحَابِ النَّارِ قَالُوا رَبَّنَا لَا تَجْعَلْنَا مَعَ الْقَوْمِ الظَّالِمِينَ (47)﴾. هو وجهه تجاه الجنة يرى فيها أصحاباً له كانوا معه في الطاعات فيناديهم سلام عليكم طمعاً في أن يدخل الجنة، لكن لم يأتي إذن بالدخول، فيبقى على الأعراف حتى يقضي الله بينه وبين أبويه. صرف الله وجهه عن النار ومجرد صرف الوجه عن النار نعيم، فعندما يلتفت ويرى أصحاب النار يقول ربنا لا تجعلنا مع القوم الظالمين لما رأى من سوء عاقبة نعوذ بالله من النار. إذا الشهادة في سبيل الله طاعة ما أعظمها، لكن يعلوها أن تعيش في طاعة أبويك محسناً باراً غير عاق.

بسم الله الرحمن الرحيم لمن يعرف المكتبة الشاملة أهدي له رابط واحد مباشر حجمه 4.5 جيجا بايت للمكتبة الشاملة الإصدار 3.15 به 6688 كتاب ولمن لم يعرفها بعد فهي: المكتبة الشاملة الهدف من هذه المكتبة ليس مجرد جمع بعض الكتب المجانية من الإنترنت في مكتبة واحدة بل الأهم من ذلك هو إمكانية إضافة الكتب وتعديلها لتكون المكتبة الشخصية لطالب العلم والمكتبة مجانية ويمكن تحميلها من موقع المكتبة مجانا shamela.ws لا يجوز استخدامها لنشر ما يخالف منهج أهل السنة والجماعة. وليس هذا تضييقا على طالب العلم ، بل يجوز لطالب العلم المتبصر أن يضع من كتب أهل البدع مثلا ليرد عليها أو نحو ذلك أما نشر هذه الكتب فإن من شرط جواز استخدام هذه المكتبة عدم استعمالها في ذلك يجوز - بل يشجع - نشر المكتبة على اسطوانات أو في المنتديات أو على مواقع الإنترنت للحصول على آخر تحديثات البرنامج وآخر الكتب المضافة استخدم خاصية الترقية الحية في البرنامج أهم التحديثات 1- الآن صارت الشاملة portable لا تحتاج لتنصيب ، وتعمل على نظام التشغيل ويندوز من 95 حتى فيستا ، ودعم أفضل للشبكات (يمكن لأكثر من مستخدم على الشبكة استخدام الشاملة، ويكون لكل مستخدم على الشبكة خياراته الخاصة ومجالات بحثه ونحو ذلك) 2 - إضافة خدمة التخريج لكتب الحديث النبوي 3 - التحديث التلقائي من الإنترنت : هذه الخاصية تتعرف على الكتب التي تنقصك فقط ، من موقع البرنامج وتعطيك روابط مباشرة لتحميلها، وأيضا تكتشف إن كان إصدارك الحالي من الشاملة هو آخر إصدار أم هناك إصدار أحدث منه ، ورابط تحميله 4 - تمييز كتب الموقع الرسمي عن غيرها ، وبإمكانك وأنت تتصفح أي كتاب من كتب الموقع الرسمي أن تدخل مباشرة لصفحة الكتاب على الموقع 5 - إمكانية ربط كتاب الشاملة بكتاب مصور pdf موافق لترقيمه، بحيث يمكنك وأنت تتعامل مع كتاب الشاملة أن تصل لنفس الموضع من الكتاب المصور وتستعرضه من داخل الشاملة. وكتب الموقع الرسمي يمكن ربطها بنسخ مصورة حتى مع اختلاف الترقيم 6 - تحسينات في الاستيراد ، أهمها إمكانية استيراد الملف مطابقا لملف الوورد، بحيث تكون كل صفحة وورد في صفحة شاملة، وبنفس ترقيم الصفحة، واستيراد الشعر المنسق عموديا بطريقة سليمة، وأيضا إمكانية استيراد الملفات المضغوطة zip و rar دون الحاجة لفك ضغطها ، وغير ذلك 7 - تحسين فهارس البحث، بحيث لا يهنج الجهاز عند فهرسة أي كتاب مهما كان حجمه 8 - إمكانية التدقيق الإملائي للكتب من داخل الشاملة ، باستخدام قاموس الوورد، أي أن تصويبات واقتراحات الوورد تأتيك داخل الشاملة- دون الحاجة لأن تفتح أنت الوورد إطلاقا - ، لكن مع الاستعانة بقاموس آخر خاص بالشاملة، يمكنك إضافة ما شئت من الكلمات إليه، بدلا من قاموس الوورد المحدود بعدد معين من الكلمات 9- زيادة في سرعة البحث سواء كانت بالفهارس أم بدن فهارس ، تصل لأكثر من ضعف سرعة الإصدار السابق ، وقدرها بعض من اختبرها بـ 65 % أو أكثر ، والحمد لله 10- تحسينات أخرى كثيرة في عامة شاشات البرنامج : مثلا ، بمجرد الإشارة لزر البطاقة، يظهر لك تلميح ببطاقة الكتاب، وإضافة خدمات مثل تغيير ترتيب جميع كتب البرنامج نهائيا (أبجديا أو حسب الوفيات)، واستخدام القص واللصق لنقل ولترتيب الكتب في شاشة التحكم ، وغير ذلك مما لا مجال لذكره هنا وهذه صورة الشاشة الرئيسية ولمن لا يستطيع تحميل المكتبة لبطء النت لديه فهذه هدية أخرى يمكنك تصفح الكتب من على النت من هذا الرابط https://al-maktaba.org/#categories وهذا الرابط للتحميل والآن مع التحميل والجميل في هذا الملف أن فك الضغط عنه لا يستغرق سوى 10 دقائق وليس مثل مجموعة الروابط المقسمة إلى 39 جزء وحجمها 3.63 جيجا بايت والتي يتم فك الضغط عنها في أكثر من 5 ساعات وفي الأخير لا تنسوا أخاكم محمد صالح من صالح دعائكم

السلام عليكم 🙂 اعرف ان هذا الموضوع مخالف ، فلا علاقة له بالاكسس ، ولكن له علاقة بالمبرمج 🙂 ملف اكسل فيه اوراق لتسهيل قضاء الصلوات الفائته - أدوات عامة - أوفيسنا (officena.net) جعفر

اتفضل اخى حسام وحاول تعدل علشان تتلافى المشاكل دى وخلى التسميات بالعربى فى تسميه توضيحيه Private Sub kindEsal_AfterUpdate() 'kindEsal - نوع الاصال If kindEsal = "دفع نقدى" Then If Len(Forms("البيانات الرئيسيه").Form.[ZDate] & "") = 0 Then Forms("البيانات الرئيسيه").Form![krd] = 0 Forms("البيانات الرئيسيه").Form.[numKrd] = 0 Forms("البيانات الرئيسيه").Form.[kst] = 0 End If End If End Sub بالتوفيق

اعتقد ان الباس هو 1

جعفر

واياكم اخى وجزا الله اخى خالد وجميع اخواننا واساتذتنا خيرا اتفضل ان شاء الله يكون ما تريد اول خطأ فى مصدر سجلات النموذج وضعت معيارك ثم فى حدث بعد التحديث لحقل الكمبو text3 وضعت Private Sub text3_AfterUpdate() Me.Requery End Sub بالتوفيق New Microsoft Access Database (3)(1).rar

السلام عليكم مشاركه لاخى واستاذى العزيز @أبو عبدالله الحلوانى جزاه الله خيرا محاوله منى لانى كمان تهت فشرحك @احمد حبيبه هل هذه النتيجه التى تريدها من واقع البيانات بالمثال تبعك ان لم تكن فبرجاء الشرح اكثر ع البيانات الموجوده بالمثال وان شاء الله ربنا هيسرها بالحل بالتوفيق

السلام عليكم اتفضل اخى ان شاء الله يكون ماتريد جرب ووافنا بالنتيجه فى حدث بعد التحديث لنوع الايصال Private Sub kindEsal_AfterUpdate() 'kindEsal - نوع الاصال If kindEsal = "دفع نقدى" Then With Forms!form1! If Len(.ZDate & "") = 0 Then .krd = 0 .numKrd = 0 .kst = 0 End If End With End If End Sub بالتوفيق New Microsoft Office Access Application.mdb

الشكر لله ثم لاخواننا واساتذتنا جزاهم الله خيرا 💐

اذا جرب هذا التعديل New Microsoft Access 11111.accdb

تضامنا مع ما تفضل به استاذنا خالد هذه نفس الخطوات لنسخة انكليزية

شكرا لك استاذ ( SEMO.Pa3x , احمد الفلاحجي ) هذا هو المطلوب بالفعل ....

افتح التقرير في عرض التصميم ثم في تفصيل التقرير اعمل مثل الصورة

شكرا لله ثم لك أستاذ احمد الفلاحجي

تم حل هذه الاشكالية بالمرفق الجديد ، فيصبح حدث النقر المزدوج في الحقل: Private Sub EH_DblClick(Cancel As Integer) Dim lng_Mno As Long 'send the "UnSaved Text" (to retain the text position as is), and the click position to the Function Get_Number 'to retrieve the number clicked on lng_Mno = Get_Number(Me.EH.Text, Me.EH.SelStart) 'once the Function returns the value, examin it If lng_Mno = 0 Then MsgBox "لم يتم الحصول على رقم" ElseIf lng_Mno = 1 Then MsgBox "لم يتم التعرف على الخطأ" Else DoCmd.OpenForm "مسند", , , "[Mno]=" & lng_Mno End If End Sub والدالة في الوحدة النمطية: Option Compare Database Option Explicit Public Function Get_Number(fld As String, P As Long) As Long On Error GoTo err_Get_Number ' 'fld = Field content 'P = Position left mouse was double clicked in the field 'max_Length = maximun length of numeric field, default is 10 on each side = 20 characters 'C = the character to check 'Add_C = Adds the numeric Characters ' '1. check the characters to the Left <----| '2. check the characters to the Right |----> ' ' jjafferr ' v.1 : 21-01-13 : initial re;ease ' v.1.1 : 21-01-14 : added error traping for noe numeric values ' Dim i As Integer Dim Add_C As String Dim C As String Dim max_Length As Integer max_Length = 10 'What dose Access Read: -10 to 10 = 20 letters/characters 'C = Mid(fld, P - max_Length, max_Length) & vbCrLf & Mid(fld, P + 1, max_Length) 'Debug.Print C 'Get the numbers on the Left side of the click For i = P To (P - max_Length) Step -1 C = Mid(fld, i, 1) 'loop through the characters one at a time If IsNumeric(C) Then 'test the character to our condition Add_C = C & Add_C 'passed the condition, Concatenat it Else Exit For 'did NOT pass the condition, get out of the loop End If Next i 'Debug.Print Add_C 'Get the numbers on the Right side of the click P = P + 1 For i = P To (P + max_Length) C = Mid(fld, i, 1) If IsNumeric(C) Then Add_C = Add_C & C Else Exit For End If Next i 'Convert the concatenated string to Long, and 'return the number value Get_Number = CLng(Add_C) Exit_Get_Number: Exit Function err_Get_Number: If Err.Number = 13 Then Get_Number = 0 ElseIf Err.Number = 5 Then Get_Number = 1 Else Get_Number = 1 MsgBox Err.Number & vbCrLf & Err.Description End If 'don't break the code, so Resume by exiting from the Function Resume Exit_Get_Number End Function انا لم اقل هذا ، وإنما قلت جعفر 1326.2.Get Number between text.accdb.zip

لا لا ، المسألة ليست الاكسس و اكسل ، وإنما اكسس او اكسل !! وفي انتظار قرارك 🙂 جعفر

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

مشاركه مع الدكتور حسنين جزاه الله خيرا 💐 محاوله بسيطه على قدر معرفتى [fatora1] & Left([fatora2];2) & Mid([fatora2];4;2) filed.accdb

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

الشكر لله ثم لاخواننا واساتذتنا جزاهم الله خيرا تعديل تجميع حسب لحقل التاريخ الى WHERE SELECT Table1.nom, Table1.Designation, Sum(Table1.ts) AS Sumts FROM Table1 WHERE (((DateValue([datefacture]))>=#1/8/2021# And (DateValue([datefacture]))<=#1/9/2021#)) GROUP BY Table1.nom, Table1.Designation; بالتوفيق

وعليكم السلام اخى @rey360 اتفضل ان شاء الله يكون ما تريد ويمكنك تحويل الاستعلام ل vba كما تريد بالتوفيق test.accdb

تم حل المشكلة وربط الجداول اما الفورم كان لا يظهر بسبب id لم يكن نازل في الاستعلام شكرا لكم على المساعدة

السلام عليكم ورحمة الله وبركاته في البداية .. استخراج بيانات الجنس .. عن طريق الدالة .. لاستخراج القيم الفريده في العامود =IFERROR(INDEX($D$3:$D$9, MATCH(0,COUNTIF($D$16:D16, $D$3:$D$9), 0)),"") او الدالة =UNIQUE(D3:D9) لاستخراج التاريخ .. =IF(D17="","",MAX(IF($D$3:$D$9 = D17, $C$3:$C$9))) نموذج.xlsx

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

ارجو ان يكون هو المطلوب ايجار معدات للغير.accdb

هكذا؟ نموذج.xlsm

السلام عليكم ورحمة الله وبركاته تفضل اخوي العزيز .. تم تغيير الاجازة يوم الجمعة والسبت .. tf02780235_win321.xlsx

السلام عليكم ورحمة الله اكتب المعادلة التالية فى الخلية "B13" ثم اسحبها طولا و عرضا =INDEX($A$2:$D$6;COUNTA($A$2:$A$6)-COLUMN()+2;MATCH($A13;$B$1:$D$1;0)+1)

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

السلام عليكم ورحمة الله وبركاته جرب الملف .. اختر الملف المراد جلب البيانات منه .. بالضغط على جلب البيانات .. عن طريق الدالة VLOOKUP يفضل اخوي العزيز .. ان يكون البحث برقم الطالب افضل من اسمه .. new.xlsm

وعليكم السلام-تفضل أسماء جميع العاملين بالمدرسة.xlsm

شكراً على هذا التذكير الاستاذ سليم فعلاً قدم حل رائع جداً . وقد قمت بعمل اعجاب للحل شكراً للجميع

تم اضافة المجموع .. newworkbooks.xlsm

قليل من التنسيق الاصافي بجيث يظهر لك مكان وجود الرصيد (اسم الشيت) مع تلوينه باللون الاصفر في الشيت Option Explicit Sub get_data() Dim Inf As Worksheet Dim sh As Worksheet Dim OBJ As Object Dim OBJ_name As Object Dim S_rg As Range Dim first_row%, sec_row%, m% Dim max_ro%, Arr, ky Dim iNCLR As Range, iNCLR_RO% Set OBJ = CreateObject("Scripting.Dictionary") Set OBJ_name = CreateObject("Scripting.Dictionary") Set Inf = Sheets("Info") '+++++++++++++++++++++++++++++ For Each sh In Sheets If sh.Name <> Inf.Name Then Set iNCLR = sh.Range("B2").CurrentRegion iNCLR_RO = iNCLR.Rows.Count If iNCLR_RO > 2 Then iNCLR.Offset(2).Resize(iNCLR_RO - 2). _ Interior.ColorIndex = xlNone End If End If Next '++++++++++++++++++++++++++++++++ max_ro = Inf.Range("B2").CurrentRegion.Rows.Count If max_ro > 2 Then Inf.Range("B2").CurrentRegion. _ Offset(2).Resize(max_ro - 2).Clear End If If Inf.Range("J1") = vbNullString Then Exit Sub For Each sh In Sheets If sh.Name <> Inf.Name Then Set S_rg = sh.Range("C:C").Find(Inf.Range("J1"), lookat:=1) If Not S_rg Is Nothing Then first_row = S_rg.Row: sec_row = first_row Do sh.Cells(sec_row, 2).Resize(, 7) _ .Interior.ColorIndex = 6 Arr = sh.Cells(sec_row, 3).Resize(, 6) Arr = Application.Transpose(Arr) Arr = Application.Transpose(Arr) OBJ(OBJ.Count) = Join(Arr, "*") OBJ_name(OBJ_name.Count) = sh.Name Set S_rg = sh.Range("C:C").FindNext(S_rg) sec_row = S_rg.Row If sec_row = first_row Then Exit Do Loop End If 'find End If 'name Next 'sh m = 3 If OBJ.Count Then For Each ky In OBJ.keys With Inf.Cells(m, 3) .Resize(, 6) = Split(OBJ(ky), "*") .Offset(, -1) = m - 2 .Offset(, 6) = OBJ_name.Item(m - 3) m = m + 1 End With Next With Inf.Range("B3").Resize(m - 2, 8) .Value = .Value .Columns(5).Formula = "=SUM(D3,-E3)" .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 19 .Value = .Value End With Inf.Cells(m, 2) = "المجموع" Inf.Cells(m, 4).Resize(, 3).Formula = _ "=SUM(D3:D" & m - 1 & ")" Inf.Range("B" & m).Resize(, 7). _ VerticalAlignment = 2 Inf.Cells(m, 2).Resize(, 2). _ HorizontalAlignment = 7 With Inf.Range("B" & m).Resize(, 8) .Value = .Value .Interior.ColorIndex = 35 End With Else MsgBox "This Name Not Exists" End If End Sub الملف من جديد Sandook_NEW.xlsm

جرب هذا الملف Option Explicit Sub get_data() Dim Inf As Worksheet Dim sh As Worksheet Dim OBJ As Object Dim S_rg As Range Dim first_row%, sec_row%, m% Dim max_ro%, Arr, ky Set OBJ = CreateObject("Scripting.Dictionary") Set Inf = Sheets("Info") max_ro = Inf.Range("B2").CurrentRegion.Rows.Count If max_ro > 2 Then Inf.Range("B2").CurrentRegion. _ Offset(2).Resize(max_ro - 2).Clear End If If Inf.Range("J1") = vbNullString Then Exit Sub For Each sh In Sheets If sh.Name <> Inf.Name Then Set S_rg = sh.Range("C:C").Find(Inf.Range("J1"), lookat:=1) If Not S_rg Is Nothing Then first_row = S_rg.Row: sec_row = first_row Do Arr = sh.Cells(sec_row, 3).Resize(, 6) Arr = Application.Transpose(Arr) Arr = Application.Transpose(Arr) OBJ(OBJ.Count) = Join(Arr, "*") Set S_rg = sh.Range("C:C").FindNext(S_rg) sec_row = S_rg.Row If sec_row = first_row Then Exit Do Loop End If 'find End If 'name Next 'sh m = 3 If OBJ.Count Then For Each ky In OBJ.keys With Inf.Cells(m, 3) .Resize(, 6) = Split(OBJ(ky), "*") .Offset(, -1) = m - 2 m = m + 1 End With Next With Inf.Range("B3").Resize(m - 2, 7) .Value = .Value .Columns(5).Formula = "=SUM(D3,-E3)" .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 19 .Value = .Value End With Inf.Cells(m, 2) = "المجموع" Inf.Cells(m, 4).Resize(, 3).Formula = _ "=SUM(D3:D" & m - 1 & ")" Inf.Range("B" & m).Resize(, 7). _ VerticalAlignment = 2 Inf.Cells(m, 2).Resize(, 2). _ HorizontalAlignment = 7 Inf.Range("B" & m).Resize(, 7).Value = _ Inf.Range("B" & m).Resize(, 7).Value Inf.Range("B" & m).Resize(, 7). _ Interior.ColorIndex = 35 Else MsgBox "This Name Not Exists" End If End Sub الملف مرفق Sandook.xlsm

1-ليس من الضرورة رفع ملف يجتوي على اكثر من 1500 صف لان الماكرو الذي يعمل على صف واحد بستطيع العمل على الوف الصفوف 2- تم اختصار الملف الى حوالي 80 صف لمتابعة عمل الماكرو 3-الكود Option Explicit Dim sh As Worksheet Dim New_sh As Worksheet Dim lr%, Cont#, i%, x%, k% Dim SectionName As Range Const How_Many = 20 '+++++++++++++++++++++++++++++++ Sub Del_sheets() Application.DisplayAlerts = False For Each sh In Sheets If sh.Name Like "Section*" Then sh.Delete End If Next Main.Select Application.DisplayAlerts = True End Sub '++++++++++++++++++++++++++++++ Sub insert_Sheets() Del_sheets Set SectionName = Main.Range("D3:K3") lr = Main.Cells(Rows.Count, 3).End(3).Row Cont = (lr - 1) / How_Many If Int(Cont) <> Cont Then Cont = Cont + 1 End If Cont = Int(Cont) For i = 1 To Cont Sheets.Add(, Sheets(Sheets.Count)).Name = "Section_" & k * How_Many + 1 k = k + 1 SectionName.Copy With ActiveSheet.Range("D3") .PasteSpecial (xlPasteAll) .PasteSpecial (8) End With Next Application.CutCopyMode = False Main.Select End Sub '++++++++++++++++++++++++++++++++++++ Sub fil_data() Application.ScreenUpdating = False insert_Sheets x = 4 For Each New_sh In Sheets If New_sh.Name Like "Section*" Then Main.Range("D" & x).Resize(How_Many, 9).Copy New_sh.Range("D4").PasteSpecial (xlPasteAll) New_sh.Range("D4").PasteSpecial (8) x = x + How_Many End If Next Application.ScreenUpdating = True Main.Select End Sub 4-الملف مرفق Taksim_Ahmad.xlsm

اتفضل استاذ اليك هذا Public Sub OpenDocument(DocPath As String) Dim A As Long A = Shell("RUNDLL32.EXE URL.DLL,FileProtocolHandler " & DocPath, vbMaximizedFocus) End Sub Private Sub Command1_Click() Call OpenDocument("C:\Users\Shivan\Desktop\TEST.pdf") End Sub

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

عمل أكثر من رائع من أخ أروع هذا يجعل الفكرة أكثر تنوعا فجزاك الله ألف خير