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

بسم الله الرحمن الرحيم اليوم سنقوم بشرح طريقة ربط الفيجوال بيسك بالإكسيل اولا نعمل مشروع جديد عبارة عن فورم وواحد كمبوبوكس وسته تكست وثمانية ليبل وخمس أزرار وملف اكسيل بامتداد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

السلام عليكم مثال قديم للأستاذ أبو هاجر لاستخدام الماسح ( السكانر ) عن طريق الأكسس قمت على تحديثه وزيادة السيطرة واستبعاد تخزين مسار الصور حيث لا داعي لها . مرفق ملف مكتبة dll يجب نسخه في مجلد Windows\System . لا تنسونا من دعاكم . تحياتي . الملفات المرفقة Scanner.rar ( 471.28ك ) عدد مرات التنزيل: 38

ابحث عن برنامج حسابات مصنع ملابس

السلام عليكم ورحمة الله وبركاته الموضوع هذا بدأ بسؤال الرابط التالي: http://www.officena.net/ib/topic/65783-البحث-عن-اي-جزء-من-الكلمة-عنوان-معدل/ ولكن لأني غيرت الكود وجعلته يبحث في اي عدد من الحقول في السجل ، لذا رأيت ان اجعل له موضوعا مستقلا يمكنك البحث عن اي جزء من الكلمة ، واذا اردت البحث عن كلمة اخرى في السجل او جزء منها ، فما عليك الا ان تضع (مسافة او / او *) بين الكلمات ، فسيعتبرها البرنامج على انها كلمة اخرى يجب البحث عنها. الشئ المهم في الكود هو طريقة إضافة حقول جديدة للبحث فيها: هذا اول حقل يتم البحث فيه fld = "[كلمات ارشادية]" لما نريد ان نضيف حقول إضافية للبحث فيها ، يجب ان يكون الكود كالتالي fld = fld & " & ' ' & " & "[موضوع الخطاب]" fld = fld & " & ' ' & " & "[my other field]" وكل ما عليك الآن هو ان تطبع وترى نتيجة بحثك: . ملاحظة مهمة: اذا كان برنامجك على الشبكة ، فلا تضع الكود على "حدث التغيير" (معناه ، كلما اضفت/حذفت حرف ، فارجع الى الجدول وخذ البيانات منه) ، لأنه سيجعل البرنامج جدا بطئ ، وانما استخدم زر البحث. جعفر 309.Search_as_you_Type_Multiple_Fields_jj.mdb.zip

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

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

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

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

اخي الغالي عبد العزيز بالفعل مش هيشتغل لازم ترفق معاه ملف الاكسيل لانه يعتبر قاعده بياناته يعني الملف التنفيذي ومعه ملف الاكسيل

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

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

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

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

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

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

الله الله عليك أنت اللى ملكش حل رووووووووووووووووووووووووووووووووو عة يا غالى بارك الله فيك ونفع بك وجعل فى ميزان حسناتك

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

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

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

السلام عليكم ورحمة الله اليك الحل New Microsoft Excel Worksheet.rar

السّلام عليكم و رحمة الله و بركاته نحن بانتظار سلسلة دروسك الشيّقة أستاذي الغالي " ياسر العربي " تحياتي

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

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

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

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

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

سلمت الأنامل وجزاك الله خيراً هذا هو المطلوب بارك الله وبالتوفيق

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

أخي الكريم حامد عشان متقولش إننا مقصرين معاك إليك الملف التالي مشابه لطلبك تقريباً .. Multiple Corresponding VLOOKUP Values Across Rows YasserKhalil.rar

أخي الكريم أبو يوسف إليك كود آخر أسرع في التعامل مع الملف حيث أنه يعتمد على المصفوفات Sub YasserReport() Application.ScreenUpdating = 0 Dim Arr, Xs$, Brr, Dc, Sn%, D As Object, DD As Object, TT(), SSS() Dim S As Worksheet Dim K, T, C, I As Long, J As Long Set D = CreateObject("scripting.dictionary") Set DD = CreateObject("scripting.dictionary") SSS = Array("المادة", "عدد الطلاب") Xs = ActiveSheet.Name For Each S In Sheets If S.Name <> Xs Then Arr = S.UsedRange: Dc = "" For I = 1 To UBound(Arr, 2) If Len(Arr(19, I)) = 0 Then Arr(19, I) = Arr(19, I - 1) If Len(Arr(21, I)) > 0 Then Dc = Dc & "|" & I Next Dc = Split(Dc, "|") ReDim Brr(1 To UBound(Arr) - 18, 1 To UBound(Dc)) For I = 19 To UBound(Arr) For J = 1 To UBound(Dc) Brr(I - 18, J) = Arr(I, Dc(J)) Next Next Sn = UBound(Brr, 2) - 1 For I = 3 To UBound(Brr) Step 2 For J = Sn - 2 To 1 Step -1 If Val(Brr(I, J)) Then D(Brr(I, Sn) & "|" & Brr(1, J)) = Brr(I, Sn) & "|" & Brr(1, J) & "|" & Brr(I, J) End If Next Next End If Next Debug.Print D.Count K = D.keys T = D.Items For Each C In K DD(Split(C, "|")(0)) = "" Next K = DD.keys ReDim TT(UBound(K)) With Sheets(Xs) [A1] = "اسم المدرسة" [A2].Resize(DD.Count, 1) = Application.Transpose(K) For I = 0 To UBound(K) TT(I) = Filter(T, K(I)) For J = 0 To UBound(TT(I)) Cells(I + 2, J * 2 + 2) = Split(TT(I)(J), "|")(1) Cells(I + 2, J * 2 + 3) = Split(TT(I)(J), "|")(2) Next Next I = [A1].CurrentRegion.Columns.Count For J = 2 To I Step 2 Range(Cells(1, J), Cells(1, J + 1)) = SSS Next Application.ScreenUpdating = 1 End With End Sub وإليك الملف المرفق الأخير Grab Data From Sheets Colored In Red Or White YasserKhalil V2.rar

السلام عليكم ورحمة الله ولإثراء الموضوع هذا كود من إبداعي ودن الرجوع لاي مصدر كود صغير جدا خفيف وسهل من 7 كلمات Dim MySh MySh = "KHMB" Sheets(MySh).Select يتم وضعة في حدث النقر علي زر الامر مرفق المثال KHMB الذهاب الي الشيت المحدد من الفورم.rar

أخي الكريم أبو حمادة قم بوضع الكود التالي في موديول عادي 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

السلام عليكم ورحمة الله بعد إذن اخونا وإستاذنا الفاضل ياسر خليل إليك الملف إن شاء الله يكون حسب طلبكم هذا مما تعلمناه من العلامة القدير الاستاذ / عبدالله احمد باغشير والذي غاب عننا ربنا يرفع عنهم وعننا وسائر بلاد المسلمين البلاء والوباء والغلاء. الإنتقال الي الصفحة بدلالة إسمها علي الزر.rar

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

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

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

أخي الكريم جرب الملف المرفق التالي ** الكود مقسم إلى كود يوضع في موديول عادي 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

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

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

السلام عليكم دي دالةقديمة عملتها بالكود يمكن تنفع معاك المرفق2003/2007 الفرق بين تاريخين.rar

للتوضيح ال RANGE (B1:C1 ، E1:F1 ) عبارة عن المدى من الخلابا B1:C1 الى مدى من الخلايا E1:F1 فهو الى وليس و يعن نقدر نقول Range(Start,End) eg وال End اختياري فالموضوع ليس يقبل اثنين او ثلاثة ولكنه من الى فقط فلو وضعت(" Range("A1","Z1 فمعناه من A الى Z وليس AوZ لكن لو كتبت(" Range("A1,Z1 فمعناه A وZ وبهذا ممكن تكتب( "Range("A1,B2,C3:C10,D8,AB5,F3:G8 يعني مدى متقطع ارجو اكون وفقت اوصل معلومة تحياتي هو كلامك مظبوط بس هو كان المقصود ان اي نطاق بين علامتين تنصيص اكثر من مرتين غير مقبول وجرب انت بنفسك ** يعني تحدد أكثر من خلية بالنطاق كالتالي : Range("A13,A18,D14:D18,E21,F14,F9,C11:F11").Select يمشي تمام اخترت اكثر من خلية ونطاقة من الخلايا ضمن التحديد ** وكمان ينفع كده : Range("A1:E9").Select طبعا ده عادي نطاق عبارة عن من الى ** لكن اللي كان مقصود التالي : Range("G20", "G19").Select اختيار مفيهوش مشاكل Range("G20", "G19", "F8").Select هو دة اللي كان القصد انه ميصلحش لانه محدد 3 نطاقات بين 3 اقواس مضاعفة ارجو ان يكون التوضيح وصل ، ولو فيه اي غلط ياريت توضحه لينا