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

بسم الله الرحمن الرحيم اليوم سنقوم بشرح طريقة ربط الفيجوال بيسك بالإكسيل اولا نعمل مشروع جديد عبارة عن فورم وواحد كمبوبوكس وسته تكست وثمانية ليبل وخمس أزرار وملف اكسيل بامتدادxlsx واسمه aseel امتداده اظن لا يدعم وحدات الماكرو بس عادي مع الفيجوال شغال بنفس ترتيب الشكل الاتي: خلصنا الشكل السابق ندخل علي الشغل الجديد بقي كلنا أكيد سمعنا عن المتغيرات وكلنا تعاملنا معاها قبل ما نشوف المتغيرات الفيجوال عشان نربطه بالإكسيل لازم له مراجع ومتغيرات عامة على مستوى المشروع بأكمله إيه الكلام دا بيتعمل ازاي المرجع دا ولا بنجيبه منين شوفو معايا الصور بعد الخطوات دي ياترى بنعرف نضيف موديول زي ما بنضيف فورم جديد كدا اللي بيعرف يضيف اللي مش عارف ينزل للصورة معايا ويشوف ايه البيانات دي يامعلمين دي بقي المتغيرات العامة اللي بنقول عليها وبتكون علي مستوى المشروع بأكمله يعني لازم تتحط في موديول ولتبسيط الكلام اللي فوق دا بطريقة سهلة اول سطر Public YXL As New Excel.Application YXL دا متغير يشير الى برنامج الاكسيل نفسه بمعنى عندما نريد ان نكتب في الاكسيل Application. Visible = False نكتبه كدا YXL. Visible = False اكيد وصلت الفكرة ولو مش وصلت نكمل مثال كمان المتغير ونظيره في الإكسيل YWB= Workbook YSheet= Worksheet YRng= Range اكيد الامور اصبحت سهلة كدا أي كود في الإكسيل نستبدل المذكورين في أعلاه بنظره في الإكسيل وسيعمل الكود بإذن الله يعني مش هتخترع اكواد جديدة هي نفس القديمة بس تعديلات طفيفه المهم الكل يكون عمل الفورم والموديول والاداوت كما ذكرت سابقا بالترتيب الموجود عشان الاكواد متتبدلش مع الادوات نيجي بقي للاكواد Private Sub Combo1_Click() 'جدا الكمبوبوكس ومنه بيتم جلب البيانات بمعلومية الرقم والكود طبعا مفيهوش جديد نفس اكواد الاكسل With YSheet LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row For iRow = 6 To LastRow If .Cells(iRow, 2) = Combo1.Text Then Text1.Text = .Cells(iRow, 2) Text2.Text = .Cells(iRow, 3) Text3.Text = .Cells(iRow, 4) Text4.Text = .Cells(iRow, 5) Text5.Text = .Cells(iRow, 6) Text6.Text = .Cells(iRow, 7) End If Next End With End Sub Private Sub Command1_Click() Dim lstrow As Long 'ودا كود ترحيل البيانات ونفس الشئ مش جديد كل اللي اتغير اللي ذكرنااه If Text1.Text = "" Then MsgBox "íÌÈ ÇÏÎÇá ÌãíÚ ÇáÈíÇäÇÊ" Else lstrow = YSheet.Range("b20000").End(xlUp).Row + 1 YSheet.Cells(lstrow, "b").Value = Text1.Text YSheet.Cells(lstrow, "c").Value = Text2.Text YSheet.Cells(lstrow, "d").Value = Text3.Text YSheet.Cells(lstrow, "e").Value = Text4.Text YSheet.Cells(lstrow, "f").Value = Text5.Text YSheet.Cells(lstrow, "g").Value = Text6.Text Text1.Text = "" Text2.Text = "" Text3.Text = "" Text4.Text = "" Text5.Text = "" Text6.Text = "" MsgBox ("ÊãÊ ÇáÚãáíÉ ÈäÌÇÍ") End If End Sub Private Sub Command2_Click() 'ودا كود اظهار برنامج الاكسيل بردو غيرنا اللي اشرنا ليه فقط YXL.Visible = True End Sub Private Sub Command3_Click() ' ودا لاخفاء برنامج الاكسل YXL.Visible = False End Sub Private Sub Command4_Click() 'لحفظ البرنامج المفروض المتغير يكون شغال بس مش عارف سبب المشكلة ايه حاليا فقلت اجرب الكود العادي اشتغل تمام مشي حالك 'åäÇ ãÔ ÚÇÑÝ ÇáãÊÛíÑ åäÇ ÞÝÔ ãÚÇíÇ æãÔ ÚÇíÒ íÍÝÙ ÞáÊ ÇÌÑÈ ÇáßæÏ ÇáÚÇÏí ÇÔÊÛá ÞáÊ Òí ÇáÝá 'YWB.save ActiveWorkbook.save End Sub Private Sub Command5_Click() 'وطبعاخروج YXL.Quit Set YXL = Nothing End End Sub Private Sub Form_Load() 'هنا بنستدعي ملف الاكسيل من نفس مسار البرنامج بتاعنا ونفتحه YXL.Workbooks.Open App.Path & "/aseel.xlsx" 'اخفاء البرنامج بعد فتحه طبعا YXL.Visible = False 'هنا بقي قولنا له ان يخلي Ysheet دي تبقى الشيت الاول والاكس شيت تبقي الشيت التاني Set YSheet = YXL.Worksheets(1) Set XSheet = YXL.Worksheets(2) عادي ليبل وبياخد بياناته من خليه معينه Label7.Caption = YSheet.Range("a1").Value Label8.Caption = YSheet.Range("a2").Value With Combo1 'ودا ا لكمبوبوكس بندرج فيه بيانات الصف b For Each Data In YSheet.Range("b6:b" & YSheet.Cells(Rows.Count, "b").End(xlUp).Row) .AddItem Data Next End With End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) ودا بقي عشان لما تدوس علي علامة الاكس فوق ميخرجشي من البرنامج ويسيب ملف الاكسيل مفتوح ومخفى '' YXL.Quit Set YXL = Nothing End End Sub وبكدا نكون انتهينا من وضع الاكواد اظن الكل واخد باله انه مفيش جديد وهو دا بالتحديد مفيش جديد كل اللي عملناه واحد تايه وعرفنا السكه خلاص وبعدين محدش ينسى يعمل ملف اكسيل اه بعد دا كله يجي حد يقولي البرنامج مش شغال ليه اقوله فين ملف الاكسيل بعد الاطلاع علي البرنامج هيجي واحد يقولي ايه القلب الجميل اللي علي الفورم دا اللي مكان السهم اهو دا من ضمن اللمسات الجمالية وبيتعمل ازاي يامعلم الشرح بسيط ف الصورة معلش بدل ما اكتب الماوس كتبت الموس شغال بقى اعذروني انا بعمل الشرح في وقت قياسي وانا شغال مرفق البرنامج ومعاه القلب عشان تعملوه مكان السهم يارب اكون وصلت المعلومة صح واي خطأ منى فدا لجهلى اعذروني منتظر الردود علي فكرة الدرس دا تقريبا بنسبة كبيرة يعتبرحصرى لمنتدى اوفيسنا انا بحثت عن ربط الفيجوال بالاكسيل كثيرا وكثيرا وكود من هنا وكود من هنا حتى اكتملت الصورة امامي وتوصلت لهذا والحمد لله مع تحياتي ياسر العربي يتبع ربط الفيجوال بالاكسل.rar

مثل ما يقول المثل: الصورة بألف كلمة ، فمجموع الكلمات اللي كتبتها: 12 كلمة + 6000 كلمة (6 صور) = 6012 كلمة شرح جعفر

السلام عليكم بالمثال المرفق من اخوي جعفر وكما في الصورة ( الارقام الحمراء ) غير القيمة where المشار اليها برقم اثنين إلى group by واحذف المعيار المشار اليه برقم 3 ولا تنسى تضع اشارة صح في المربع الفارغ الظاهر

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

وعليكم السلام ورحمة الله وبركاته اليك طريقتين: الطريقة الاولى: . . . والطريقة الثانية: . . . جعفر 317.matger.accdb.zip

أخي الكريم مهند جرب الكود بعد التعديل Sub TarhilData2() Dim WS As Worksheet, SH As Worksheet Dim X As Long, Y As Long, Cell As Range Dim lRow As Long Set WS = Sheets("البيانات"): Set SH = Sheets("طبيب أطفال") Application.ScreenUpdating = False For Each Cell In WS.Range("X2:X11") If Not IsEmpty(Cell) Then X = Application.WorksheetFunction.Match(Cell.Value, SH.Rows(1), 0) lRow = SH.Cells(49, X).End(xlUp).Row + 1 WS.Range(Cell.Offset(, -22), Cell.Offset(, -20)).Copy SH.Cells(lRow, X).PasteSpecial xlPasteValues Cell.Offset(, -1).Copy SH.Cells(lRow, X + 3).PasteSpecial xlPasteValues Cell.Offset(, 3).Copy SH.Cells(lRow, X + 4).PasteSpecial xlPasteValues End If Next Cell Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

هذا الوصف واضح ، بينما الوصف السابق لم يكن تفضل نقوم بإعادة ترقيم [رقم المادة] كلما حدث حذف ، هكذا: Private Sub Form_AfterDelConfirm(Status As Integer) Dim rst As DAO.Recordset Set rst = Me.RecordsetClone rst.MoveLast: rst.MoveFirst RC = rst.RecordCount For i = 1 To RC rst.Edit rst![رقم المادة] = i rst.Update rst.MoveNext Next i End Sub جعفر 316.students.accdb.zip

السلام عليكم ورحمة الله تعالى وبركاته اولا بعد الحمد لله الذى تتم بنعمته الصالحات فسبحان الله الحنان المنان الذى هدانا وما كنا لنهتدى لولا ان هدانا الله عزوجل له الحمد حمدا كثيرا طيبا طاهرا مباركا فيه له وحده الحمد كما ينبغى لجلال وجهه ولعظيم سلطانه ثانيا ادين بالفضل بعد رب العزة سبحانه وتعالى وللكثير من اساتذتى رواد هذا الصرح الشامخ فلولا الله ثم اساتذتى الكرام لما وصلت الى هذا الحد بعد كل الشكر والتقدير اهنئ نفسى واياكم بما وصلت اليه الموضوع بإختصار هو برنامج الصلاحيات والتحكم بالمستخدمين بالفعل أرهقنى موضوع الصلاحيات هذا لو كان اختياراً لتركته وما ترددت فى ذلك لكن تبقى الضرورة وحتمية العمل به هى المحرك الأول والأخير فكانت محاولات الإستماتة حتى إنى فى إحدى اللحظات توقعت أننى لن ولم أحاول البحث أو محاولة إنشاء الصلاحيات بعد هذه اللحظة إستعصى الأمر لدرجة أنني جربت نسبة 90 فى المئة من كل ما هو مقترح على النت لحل تلك المشكلة العويصة مشكلة الصلاحيات وكما لاحظت يعانى منها الكثير غيرى لكن من الله على سبحانه وتعالى بعلمه وفضله فتوصلت لبرنامج Users maker الإصدار الثانى الذى قيل عنه انه يعمل مع منتجات الاوفيس ابتداء من 2007 وحتى 2013 ولكن من وجهة نظرى البرنامج فقير وكنت دائما أقع فى المشاكل بسببه حتى قررت أن أفتح النسخة وأحاول التعديل عليها بما يتماشى ويتناسب مع متطلباتى وأظنها متطلبات اغلب المشاركين كما لاحظت من تساؤلاتهم وإليكم أقدم لكم البرنامج بإصداره الثالث من تعديلى الشخصى وإضافتى التى لم يسبقنى إليها أحد فحاولت تلافى الكثير والكثير من التعقيدات أترك لكم التجربة والتحليل وفى إنتظار الرد للعلم حافظت على حقوق المبرمج الأصلى للبرنامج بارك الله فى علمه الأستاذ القدير محمد مهند العبادى أتحدى وجود إصدار مشابه على الانترنت لما اطرحه عليكم الأن طبعا البرنامج حجمه كبير لن أستطيع إرفاقه عن طريق المرفقات ولذلك أطلب على استحياء من أساتذتنا الكرام المسئولين عن امور المنتديات بكل الحب والود والتقدير بعد تحليل البرنامج والتأكد من فعاليته بشكل جيد وخلوه من الأخطاء إن خلا فالكمال لله وحده إعادة رفع البرنامج على سيرفر المنتدى حتى يكون مرجع فمواقع الرفع المجانية غير مستقرة معلومات هامه جدا جدا جدا عن البرنامج بعد عمل اى برنامج خاص بكم من خلال هذه الاداة Users maker -Third Edition أولا -- من نموذج الدخول أضفت عدد اثنين مستخدمين لكل منهم صلاحيات خاصة وهم مخفيين لا يظهروا بالبرنامج إطلاقاً فى الوصع الطبيعى لعمل البرنامج المستخدم الاول مميزاته الدخول على لوحة تحكم صلاحيات المستخدمين البيانات للدخول اسم المستخدم / admin كلمة المرور / 2015 ثانياً -- المستخدم الثانى مميزاته الدخول على نموذج خاص لإلغاء تفعيل زر Shift أو تمكينه وكذلك إخفاء الجداول والإستعلامات وإظهارها البيانات للدخول اسم المستخدم / superadmin كلمة المرور / 2015 وفى النهاية إن كفيت ووفيت فمن فضل الله وأن ذللت وأخطأت فمن هوان نفسى وقلة حيلتى اسالكم بكل الحب والتقدير إن رأيتم منى خطأ فتجاوزوا عنه بحلم أو صححوه لى بعلم وفى النهاية أعتذر للإطالة جزاكم الله عنى كل الخير روابط تحميل اولا: موقع ...... ميديا فاير ........ إضغط هنا للتحميل accdb for Access 2007- 2010 - 2013 موقع ...... ميديا فاير ........ إضغط هنا للتحميل mdb for Access 2000 - 2002 - 2003 ثانيا : موقع ...... بن الخليج ........ أضغط هنا للتحميل accdb for Access 2007- 2010 - 2013 موقع ...... بن الخليج ........ إضغط هنا للتحميل mdb for Access 2000- 2002 - 2003 اسألكم الدعاء للأستاذ محمد مهند العبادى المبرمج ولوالديه بظهر الغيب كما أطلب منكم على استحياء أن تتذكرونى بدعواتكم الصالحات لوالدى واللهم كما جمعتنى بصحبتكم الطيبة فى الدنيا دون أن أساله اللهم لا تحرمنى منهخا فى الجنة أنا أسألك آمين ..آمين ..آمين أخوكم العبد الفقير إلى الله محمد عصام

الحمد لله الذي بنعمته تتم الصالحات وتصبح على خير يا أخ وائل تقبل وافر تقديري واحترامي

تسلم ايدك يابركات يابو الحركات لا ياباشا تمام التمام وتصبح علي خير وسعاده وهنا

شكر وتقدير لعباقرة الاكسل والاكواد

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

اضافة للموضوع مرفق ملف من اعداد الاستاذ / عماد الحسامى - رحمه الله وادخله فسيح جناته vlookuptwo.rar

جرب معادلة الصفيف التالية =INDEX(Table1[السعر],MATCH(MAX((Table1[الصنف]=K12)*(Table1[الحركه]="مشتريات")*(Table1[التاريخ])),Table1[التاريخ],FALSE),1) لا تنسى أن تضغط على Ctrl + Shift + Enter تقبل تحياتي

1_ يرجي من السادة الكرام عندما تقوم بانشاء قاعدة بيانات ان نكون الحقول باللغة الفرنسية او اللغة الانجليرية حتى تسهل في كتابة كود (صحيح) وفي النموذج غير فيه كما تشاء الى اللغة العريبية بشرط ان لا تمس الاسماء الحقول حتى لا يطلب منك ادخال اللغة العربية في البرمجة وكتابة الكود صحيح وهذا ما افعله اقوم بنسخ و لصق و اغير في الكود فقط وشكرا

يا سلام عليك أخوي ابوخليل ، وفرت عليّ الوقت بالاضافة الى ملاحظات أخوي أبوخليل ، لا تنسى ان تضع علامة صح بيم الرقمين 2 و 3 ، حتى نتائج الحقل جعفر

تم رفع الملف مع المعادلة المطلوبة book1 salim.rar

إليك معادلة الاخ الحبيب سليم مع تعديل رقم 5 إلى 4 لتظهر النتائج بشكل صحيح (وهي الأفضل في وجهة نظري حيث أنه لا داعي لأعمدة مساعدة) SALIM.rar

الله ينور شغالة كويس في المشروع تلاقيك فتحت ملف تنفيذي قديم الملف يعمل جيدا والايقونة ظهرت تمام حول المشروع لملف تنفيذي وانت تشوف

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

وعليكم السلام ورحمة الله أخي الفاضل في استعلام الإيجارات المستحقة قم بوضع عبارة (لا) في ميعار الحقل (سدد) لكي يظهر الحقول التي لم يتم سددها عذرا أخي وأستاذي جعفر لم أرى تعليقك أثناء إدراجي تعليقي بارك الله فيك

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

ملف الريجستري الذي تحدث عنه اخي ياسر واستكمالا لكلام اخي ابو البراء هناك اكواد فقط تجبر المستخدم علي تفعيل الماكرو عند فتح الملف Enable Macros.rar

الاخ الكريم عبدالله لو استخدمت خاصيه البحث لوفرت لنفسك وقت اكبر من الانتظار راجع الرابط التالى به طلبك http://www.officena.net/ib/topic/64488-الفرق-بين-امتدادات-الاكسيل/?do=findComment&comment=419595 تقبل تحياتى

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

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

استاذى الحبيب ابو الحسن والحسين بارك الله فيك واسعدك فى الدنيا والاخره تقبل تحياتى

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

اشكرك اخى المهندس ياسر ربنا يعزك ويبارك فيك اشكرك اخى الاستاذ طلعت ربنا يعزك ويبارك فيك السلام عليكم ورحمة الله وبركاته الحمد لله الذى بنعمته تتم الصالحات هذا هو الجزء الثانى EV2.rar

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

شكرا لك اخي العزيز " ياسر " وفقكم الله لكل خير ورزقكم دوام الصحة والعافية

خير ان شاء الله اخى الفاضل ابو البراء شكرا على االاهتمام المشلكه بس انا شغال بفلاشة نت بعيد عنك وانت عارف ان الشبكه تمام ولا نقدر نقول غير كده ... احد .. احد

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

سالتهم اين يمكن ان اجد العظماء ؟ فأجابوني في المواقع العظيمة بصراحة انت رائع ياابن الاهرامات جزاك الله خيرا وبارك فيك

السلام عليكم أعذرني أخي عن التأخير.. تفضل هذا مقترح بجعل رقم السند حقل واحد وترقيم مستقل لكل سند (صرف - قبض) جربه ووافني النتيجة PreTest - Afterchange---.rar

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

أخي الكريم صلاح قينك وفين أراضيك؟؟ بقالك فترة مختفي ..لعل غيابك خير ليك وحشة والله .. مشكور على مرورك العطر بالموضوع

تفضل يا سيدي نعمل ماكرو يشتغل عند تشغيل البرنامج ، ويجب ان يكون اسمه AutoExec ، هذا الماكرو نطلب منه تشغيل الوحدة النمطية Login_Form: . الوحدة النمطية Login_Form ، تقرأ قيمة الحقل Shall_I_Open من الجدول tbl_Shall ، فاذا كانت قيمته =-1 (True) ، فانه سيفتح النموذج frm_Log-n ، وإلا فانه سيفتح النموذج frm_Home : . عند اغلاق النموذج frm_Login ، فانه يغير قيمة الحقل Shall_I_Open من الجدول tbl_Shall ، الى القيمه =0 (False) . جعفر 314.form.accdb.zip

قبل ان تستطيع الضغط على الزر الذي في الشريط الاصفر ، يجب عليك ان تضغط على رز Stop all Macro السبب في ظهور هذه الرسالة ، هو تشغيلك برنامج اكسس من مجلد غير موثوق به (للأكسس 2007 فما فوق) ، فالاكسس 2010 فما فما فوق ، يمكنك القيام بما قاله الاخ كرار ، ولن تظهر لك الرسالة مرة ثانية ، بينما للأكسس 2007 ، فيجب عليك ان تذهب الى اعدادات الاكسس ، وتختار مجلد موثوق به ، وثم تشغل برامج الاكسس من ذلك المجلد ، ولن تظهر لك هذه الرسالة مرة ثانية جعفر

ضع هذا التعبير في المربع الاول =Mid([nall];1;1) وفي المربع الثاني =Mid([nall];2;1) وهكذا حتى المربع 10 =Mid([nall];10;1) بالتوفيق

أخي الكريم أبو حمادة قم بوضع الكود التالي في موديول عادي Sub ShowForm() UserForm1.Show vbModeless End Sub Sub UnhideAll() Dim Ws As Worksheet For Each Ws In ThisWorkbook.Sheets Ws.Visible = xlSheetVisible Next Ws End Sub Sub HideAll() Dim Ws As Worksheet For Each Ws In ThisWorkbook.Sheets Ws.Visible = xlSheetHidden Next Ws End Sub أنشيء فورم وعليه 4 أزرار أوامر وقم بتسمية الأزرار باسم cmdClose للإغلاق الخاص بالفورم ، وزر أمر باسم cmdSheet والذي من خلاله يمكنك التعامل مع ورقة العمل المكتوب اسمها على زر الأمر فيخفي أوراق العمل الأخرى ويبقى ورقة العمل فقط ، وزر الأمر cmdRename ويقوم بتسمية زر الأمر السابق المسمى cmdSheet (يغير عنوان الزر وليس اسم الزر) ، وأخيراً زر أمر cmdUnhide لإظهار جميع أوراق العمل وإليك الكود الذي يوضع في حدث الفورم 'Author : YasserKhalil 'Released : 25 - Dec. - 2015 'Use : This UserForm Enables You To Navigate To Specific Sheet ' Depending On cmdSheet Caption & Hide Other Sheets. '-------------------------------------------------------------------- Private Sub cmdSheet_Click() Dim Str As String, Ws As Worksheet, Bln As Boolean Str = cmdSheet.Caption On Error Resume Next For Each Ws In ThisWorkbook.Sheets Ws.Visible = xlSheetVisible If Str = Ws.Name Then Bln = True Next Ws If Bln = True Then For Each Ws In ThisWorkbook.Sheets If Ws.Name = Str Then Ws.Activate Else Ws.Visible = xlSheetHidden End If Next Ws Else MsgBox "There Is No Such Worksheet Name", 64 End If On Error GoTo 0 End Sub Private Sub cmdRename_Click() Dim StrName As String On Error Resume Next StrName = InputBox("Rename Previous Command Button", "Rename Button") If StrName <> "" Then cmdSheet.Caption = StrName On Error GoTo 0 End Sub Private Sub cmdUnhide_Click() Call UnhideAll End Sub Private Sub cmdClose_Click() Unload Me End Sub أعلم أني قد زدت عن الطلب ..فعذراً لكن الموضوع استهواني قليلاً فقمت بعمل الفورم الذي تراه بحيث يلبي حاجة من في حاجة إليه تقبل تحياتي Navigate To Specific Sheet By Command Button Name YasserKhalil.rar

أخي الكريم أبو يوسف جرب الكود التالي عله يفي بالغرض Sub YasserReport() Dim Ws As Worksheet, Wf As Worksheet, Cel As Range Dim TN As Long, S As String, N As String, R As Long, C As Long Set Wf = Sheets("Final") Application.ScreenUpdating = False For Each Ws In Worksheets N = Ws.Name If N Like "Sheet*" Then For Each Cel In Ws.UsedRange.Offset(20, 1).Resize(, 41) If Not Cel.Row Mod 2 = 0 And Cel.Value <> 0 Then S = Ws.Cells(Cel.Row, 45) TN = Cel.Value N = Ws.Cells(19, Cel.Column) If S <> "" Then If N = "" Then N = Ws.Cells(19, Cel.Column - 1) R = 2 Do Until Wf.Range("A" & R) = S Or _ Wf.Range("A" & R) = "" And Wf.Range("B" & R) = "" R = R + 1 Loop C = 2 Do Until Wf.Cells(R, C) = N Or Wf.Cells(R, C) = "" C = C + 2 Loop Wf.Cells(R, 1) = S Wf.Cells(R, C) = N Wf.Cells(R, C + 1) = TN End If End If Next Cel End If Next Ws Application.ScreenUpdating = True End Sub إليك الملف المرفق .. لا تنسانا بدعوة بظهر الغيب تقبل تحياتي Grab Data From Sheets Colored In Red Or White YasserKhalil.rar

أبي الحبيب أبو يوسف لما توقفت عن الخواطر الإكسيلية ؟ أرجو ألا تتوقف وتواصل إبداعاتك ونشاطك بالموضوع تقبل وافر تقديري واحترامي

بارك الله فيك أخي الرائع مختار يمكن استخدام الإضافة التالية لتؤدي الغرض بعد إدراج الإضافة سيظهر زر أمر في التبويب Home باسم Get Sheet Size Get Sheets Size.rar

السّلام عليكم و رحمة الله و بركاته كمساهمة منّي في إثراء المواضيع المميّزة الرّائعة و الثّمينة من طرفك أستاذي القدير " محمد حسن المحمّد " و من طرف جميع الأساتذة الأفاضل المساهمين بهذا الموضوع فعاليّةً أو تشجيعًا طيّبًا جزاكم الله خيرًا و زادكم من علمه و فضله .. بهذا الملف المرفق في المشاركة أدناه .. قمت بكتابة اسم في الخليّة A1 .. ثم أشّرت بالماوس في بداية العمل على هذه الخليّة ذهبت الآن إلى التّبويب المشار إليه بالصّورة واختيار ما يشير إليه السّهم كذلك .. أرجو المعذرة سادتي الكرام لا أعرف التّرجمة الافتراضيّة الحقيقيّة لما يشير له السّهمان .. فقلت بنفسي الصّورة أكثر تعبيرًا من الكلمات : قمت بالتّأشير على الخانة المشار إليها بالسّهم ثم اتّبعتُ .. الآتي : قمت الاآن بالتّأشير على المربّع المشار إليه بالسّهم ..ثم أكملتُ الآتي : قمت باختيار الخلية التي ستكون بداية العمل .. مثلاً D1.. ثم الضغط على ..إنهاء .. و النّتيجة ..تجزئة الخلية A1 على عدة خلايا ..مثلما تشير له الصّورة فائق أحتراماتي تجزئة الكلمة .rar

أخي وحبيبي في الله أبو يوسف أعانكم الله على البلاء الذي ابتلاكم الله به .. ولا أملك لكم إلا الدعاء لكم أن يفرج الله عنكم ما ابتلاكم به .. وصبراً فمهما طال الليل لابد من بزوغ الفجر مساهمةً مني في الموضوع الرائع الذي بدأته ..سأساهم ولو بالقليل لعل أن يجد صدى ومنفعة لدى جميع الأعضاء أقدم لكم دالة من دوال الإكسيل وما يقابلها في محرر الأكواد الدالة هي CHAR : لمعرفة الحرف أو الرمز المقابل لرقم معين افتح ملف إكسيل وضع الرقم 1 في الخلية A1 وضع الرقم 2 في الخلية A2 ثم .. حدد الخليتين معاً وقم بسحب الخليتين من مقبض السحب .. واسحب الأرقام حتى الصف 255 أي اكتب الأرقام من 1 إلى 255 في الخلية B1 اكتب المعادلة التالية : =CHAR(A1) ثم قم بسجب المعادلة إلى آخر النطاق أي إلى الخلية B255 ستلاحظ وجود علامات ورموز وحروف في العمود الثاني ..هذا يدعى جدول الأسكي ASCII .. على سبيل المثال الأرقام من 0 إلى 9 تأخد الأرقام في جدول الأسكي من 48 إلى 57 الأرقام من 65 إلى 90 الحروف الإنجليزية الكبيرة الأرقام من 97 إلى 122 الحروف الإنجليزية الصغيرة الرقم 10 يمثل سطر جديد الرقم 32 يمثل المسافة (التي تؤخذ بالمسطرة يا باشمهندس) الرقم 44 يمثل الفاصلة , ------------------------------------------------------------------------ الدالة المقابلة للدالة CHAR في محرر الأكواد هي الدالة CHR مثال تطبيقي للاستفادة من الدالة : أنشيء ورقة عمل جديدة وضع النص التالي بهذا الشكل في الخلية A1 Yasser,Ahmed,Khalil,Salem,Baraa غير ارتفاع الصف وخليه 100 لتكون الأسماء واضحة أمامك الفاصلة تفصل بين الأسماء بفاصلة .. والمطلوب أن توضع الأسماء في نفس الخلية في أسطر متتالية أي تكون بهذا الشكل: قم بوضع الكود التالي في موديول .. Sub UseCHR() Dim str As String str = Range("A1").Value str = Replace(str, Chr(44), Chr(10)) Range("A1").Value = str End Sub يتم تعريف المتغير من النوع النصي باسم str ليحمل قيمة الخلية A1 وفي السطر الثالث يتم استبدال الفاصلة Chr(44) بسطر جديد Chr(10) ..بكل بساطة بالتالي أصبح لدينا المتغير الجديد تم فيه استبدال الفاصلة بسطر جديد .. في السطر الأخير يمكنك وضع قيمة المتغير في نفس الخلية A1 أو يمكنك وضعها في خلية جديدة كما ترغب أرجو أن تكون الخاطرة قد أعجبتكم تقبلوا وافر تقديري واحترامي

أخي الكريم جرب الملف المرفق التالي ** الكود مقسم إلى كود يوضع في موديول عادي Public Arr, ArrOut Sub RefreshArray() Dim WS As Worksheet, ArrTemp, I As Long, P As Long ReDim Arr(1, 0) For Each WS In Sheets If WS.Name <> "البحث" And WS.Name <> "تصفية البيانات المكررة " And WS.Name <> "بيانات ثانوية" Then If WS.Cells(Rows.Count, "G").End(xlUp).Row > 1 Then ArrTemp = WS.Range("A1").CurrentRegion.Columns("G").Value I = UBound(Arr, 2) + UBound(ArrTemp, 1) ReDim Preserve Arr(1, I) For I = 2 To UBound(ArrTemp, 1) If Len(ArrTemp(I, 1)) Then Arr(0, P) = ArrTemp(I, 1) Arr(1, P) = WS.Name & "/" & I P = P + 1 End If Next I End If End If Next WS ReDim Preserve Arr(1, P - 1) End Sub Sub GetSearchResult(Param As String) Dim LastRow As Long, I As Long, P As Long If Not IsArray(Arr) Then RefreshArray ReDim ArrOut(1, UBound(Arr, 2)) With Sheets("البحث") LastRow = Application.Max(.Cells(.Rows.Count, "E").End(xlUp).Row, 3) .Range("E3:E" & LastRow).ClearContents P = 0 For I = LBound(Arr, 2) To UBound(Arr, 2) If InStr(1, Arr(0, I), Param, vbTextCompare) Then ArrOut(0, P) = Arr(0, I) ArrOut(1, P) = Arr(1, I) P = P + 1 End If Next I If P > 0 And Param <> "" Then ReDim Preserve ArrOut(1, P - 1) .Range("E3").Resize(UBound(ArrOut, 2) + 1, 1).Value = Application.Transpose(ArrOut) Else .Range("B2:B26,D2:D26").ClearContents End If End With End Sub Sub RefreshList(Param As Long) Dim Arr, ArrOut1(1 To 25, 1 To 1), ArrOut2(1 To 25, 1 To 1), I As Long With Sheets("البحث") .Range("B2:B26,D2:D26").ClearContents On Error Resume Next Arr = Sheets(Split(ArrOut(1, Param - 3), "/")(0)).Rows(Val(Split(ArrOut(1, Param - 3), "/")(1))).Resize(, 56).Value If Err.Number <> 0 Then Exit Sub On Error GoTo 0 ArrOut1(1, 1) = Arr(1, 9) For I = 2 To 25 ArrOut1(I, 1) = Arr(1, I + 5) Next I For I = 1 To 25 ArrOut2(I, 1) = Arr(1, I + 31) Next I .Range("B2").Resize(UBound(ArrOut1, 1), UBound(ArrOut1, 2)).Value = ArrOut1 .Range("D2").Resize(UBound(ArrOut2, 1), UBound(ArrOut2, 2)).Value = ArrOut2 End With End Sub والجزء الثاني يوضع في حدث ورقة العمل المسماة "البحث" Private Sub TextBox1_Change() GetSearchResult TextBox1.Text End Sub Private Sub Worksheet_Activate() RefreshArray End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Columns("E")) Is Nothing Then If Target.Row >= 3 And Target.Count = 1 Then If Len(Target.Value) Then RefreshList Target.Row End If End If End Sub أرجو أن يكون المطلوب ويعالج مشكلة البطء لديك إن شاء الله تقبل تحياتي Textbox Search All Sheets YasserKhalil.rar

أخي الكريم أبو عبد الرحمن البغدادي بالنسبة للملف المرفق في ورقة البحث يرجى إعادة تنظيم الورقة بحيث يسهل الوصول لحل إن شاء المولى عندي لك حل ، ولكن يرجى إرفاق الملف مرة أخرى مع ضبط ورقة البحث بالشكل الملائم حيث لاحظت أن البيانات في العمود الأول تبدأ من الصف رقم 2 وتنتهي في الصف 26 بينما في العمود الثالث تبدأ من الصف رقم 3 وتنتهي في الصف رقم 27 كما أن البيان الخاص برقم الوزارة مكرر في العمود الأول لابد من أن يكون الملف منظم حتى يخرج العمل بشكل جيد وتكون النتائج صخيحة .. تقبل تحياتي

السلام عليكم اساتذتي التمس من حضراتكم المساعدة فيما يلي : في تقرير (( R4 )) ************* في هذا التقرير احب إظهار الآتي 1 - المعدل العام للطالب مثلا 89% ..... 2 - النتيجة العامة هل هو ناجح او راسب 3 - التقدير : ممتاز ... جيدجدا......راسب 4 - مجموع لدرجات ******************* وشكرا لكم مقدما برنامج متابعة درجات طلاب.rar