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

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

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

الأخ الفاضل أبو سليمان أقطع دراعي لو كنت فاهم حاجة هل العمل على الملفين معاً .. وكيف تريد الفرز وعلى أي أساس ؟ وحضرتك بتقول عايز كل بيان في عمود ، فلما اطلعت على الملف لقيت كل بيان في عمود ..!! فجالي صدمة ..هو الملف عالج نفسه بنفسه يا ريت إذا كانت تريد المساعدة فعلاً أن توضح المطلوب بشكل تاااااااااااااااام ويا ريت لو نتائج مرفقة بشكل المطلوب .. وصدقني فهم المطلوب يمثل 90% من الحل .................................... تقبل تحياتي

في أسفل كل مشاركة تجد كلمة "تحديد كأفضل إجابة" قم باختيار أفضل إجابة لك وانقر على الكلمة .. ومتنساش اسم الظهور للغة العربية لمعرفة كافة ما يرتبط بالتعامل مع المنتدى راجع الرابط التالي (ويا ريت كل الأخوة الجدد يطلعوا على الرابط ... للضرروة) http://www.officena.net/ib/index.php?showtopic=60147

السلام عليكم ورحمة الله وبركاته إخواني الكرام في المنتدى الحبيب سبق أن قدمت في موضوع سابق دالة مشابهة لدالة اليوم ، ولكن دالة اليوم مميزة من ناحية سنقوم بسردها بعد قليل رابط الموضوع المتعلق بشبيهة الدالة فاصل ونواصل (أصلي تعبت ... ) دا شكل الدالة المعرفة Function GetUnique(R As Range) Dim Cl As Range, J As Long With CreateObject("System.Collections.ArrayList") For Each Cl In R.Cells If Cl <> "" Then If Not .contains((Cl.Value)) Then .Add (Cl.Value) Next .Sort For J = 1 To R.Count .Add ("") Next J GetUnique = Application.Transpose(.toarray()) End With End Function ايه رأيكم في شكلها (أنا شايف إنها شكلها لطيف ...مش كدا يا أبو يوسف) تقوم الدالة المعرفة UDF والتي تسمى GetUnique ، باستخراج القيم الغير مكررة في نطاق أي القيم الفريدة في نطاق ، والجديد والمفيد أنه يمكن ترتيب القيم لتحصل في النهاية على قائمة منقحة ومصححة وخالية من التكرار والفراغات .. كل دا بضربة واحدة (ضربة معلم ..صح يا حوسو) إذاً وظيفة الدالة : الحصول على قيم فريدة اي غير مكررة - ترتيب النتائج ترتيب أبجدي - التخلص من الفراغات الموجودة في القائمة الأصلية وبالمثال المرفق سيتضح المقال كيفية عمل الدالة : بفرض أن القيم المراد استخراج القيم الفريدة منها في العمود الأول في النطاق A1:A30 نشوف العمود اللي عايزين نستخرج النتائج فيه وليكن العمود G .. اشمعنا العمود دا بالذات ، عشان العمود ده رقم 7 وأنا من عشاق الرقم 7 ومضاعفاته .. نحدد النطاق من أول الخلية G1 لحد G30 قبل ما نكتب المعادلة حددنا النطاق (برافو عليك يا حوسو) روح بقا لشريط المعادلات (مش ظاهر معاك يبقا أكيد لعبت في إعدادات الإكسيل .. ودي حاجة مش وحشة دي حاجة حلوة ، لأنها دليل إنك عايز تتعلم .. اظهر شريط المعادلات من التبويب View هتلاقي كلمة Formula Bar جنبه مربع علم عليه ..! مش أحسن ما هو اللي يعلم عليك) ضع المعادلة التالية في شريط المعادلات =GetUnique(A1:A30) ومن لوحة المفاتيح اضغط Ctrl + Shift + Enter لأن دي معادلة صفيف .. ومبروك عليك القايمة الجديدة (على أساس إنك متجوز للمرة التانية .. بس القديمة تحلا ولو كانت أحلى ..بلاش نقول وحلة لناخد مخالفة (من خاف سلم)) طيب دلوقتي أنا سامع واحد بيقولي إنت ليه بتجبرني إني أرتب القيم (أنا عايز القيم زي ما هي بدون تكرار وبدون فراغات بس الترتيب ميلزمنيش) .. أرد عليه وأقوله ولا تزعل نفسك يا حبيبي روح لمحرر الأكواد ودور على السطر اللي جاي ده واحذفه أو ضع بجانبة تعليق .. بس خلاص ! مش دي اللي هتزعلنا من بعضنا ) .Sort وأخيراً تقبلوا تحيات أخوكم أبو البراء دمتم على طاعة الله Get Unique UDF Function.rar

الأخ الفاضل astika أما آن لك أن تقوم بتغيير اسم الظهور للغة العربية يرجى تحديد أفضل إجابة ليظهر الموضوع مجاب ومنتهي تقبل تحياتي

أخي وحبيبي جمال عبد السميع أنت معلمنا ومهما قدمت فهو كغثاء السيل أما ما تقدمونه حتى ولو كان قليلاً فهو الإبداع بحق .. بارك الله لنا فيك وجزاك الله عنا خير الجزاء في الدنيا والآخرة تقبل تحياتي

مش فاهم ايه المشكلة معاك ..هل اتبعت الشرح في الفيديو ؟ راجع الشرح مرة أخرى

ومحبة مني إليك شرح كود الأستاذ الكبير والأخ الغالي مختار (اللي مش بيرد على تليفونات) Private Sub Workbook_Open() 'يقوم الكود بمسح محتويات الخلايا في كافة أوراق العمل بعد تاريخ محدد '------------------------------------------------------------------ 'الإعلان عن المتغيرات Dim SH As Worksheet 'الإعلان عن ثابت من النوع تاريخ ليمثل التاريخ المراد العمل عليه في الكود Const MyDate = #1/30/2015# 'إلغاء خاصية اهتزاز الشاشة Application.ScreenUpdating = False 'إلغاء خاصية رسائل التنبيه Application.DisplayAlerts = False 'إذا تحقق الشرط وكان تاريخ اليوم أكبر من التاريخ الثابت في الكود If Date > MyDate Then 'حلقة تكرارية لكافة أوراق العمل For Each SH In ThisWorkbook.Sheets 'مسح محتويات وتنسيقات ورقة العمل في النطاق المستخدم SH.UsedRange.Clear Next 'حفظ المصنف ThisWorkbook.Save 'رسالة تفيد أن البيانات قد تم محوها MsgBox "Sorry All Data Deleted After " & MyDate End If 'إعادة تفعيل خاصية رسائل التنبيه Application.DisplayAlerts = True 'إعادة تفعيل خاصية اهتزاز الشاشة Application.ScreenUpdating = True End Sub ومتنسناش إحنا التلاتة بدعوة بظهر الغيب (مرضتش أقول إحنا الأربعة عشان رقم 4 من المحظورات ..) أنا وإنت وابن مصر ومختار .. ولا أقولك ادعي لكل الأعضاء (كل دعوة هتتردلك)

الأخ أبو حبيبة وحنين لما تروح لمحرر الأكواد عن طريق Alt + F11 مثلاً هتلاقي في نافذة المشروع Project Window أو اسمها Project - VBA Projetc هتلاقي الكائنات الموجودة في الملف .. Sheet1 و Sheet2 و هتلاقي حدث المصنف ThisWorkbook ... انقر دبل كليك وبس خلاص إنت كدا جوا الحدث ..عيش الحدث وشوف هتعرف تعيش الحدث ولا الحدث هو اللي هيعيشك

الأخ الكريم أحمد أهلا بك في المنتدى يرجى تغيير اسم الظهور للغة الزهور اللغة العربية إليك الكود التالي عله يفي بالغرض Sub ConvertFormulaToVBA() 'لتظهر النتائج في العمود الثالث [=A1(A1-B1)] يقوم الكود بتحويل المعادلة '---------------------------------------------------------------------- Dim I As Long Application.ScreenUpdating = False 'حلقة تكرارية من الصف الأول لآخر صف به بيانات في العمود الأول For I = 1 To Cells(Rows.Count, 1).End(xlUp).Row 'الخلية في العمود الثالث تساوي الخلية في العمود الأول مضروبة في الفرق بين الخليتين Cells(I, 3) = Cells(I, 1) * (Cells(I, 1) - Cells(I, 2)) 'الانتقال للخلية التالية Next I Application.ScreenUpdating = True End Sub يرجى فيما بعد وضع المعادلات بين أقواس التنصيص الخاصة بالكود حتى تظهر بشكل منضبط تقبل تحياتي Convert Formula To VBA.rar

أخي وحبيبي في الله وأستاذنا جمال عبد السميع عوداً حميداً .. فينك يا كبير .. ليك وحشة والله ، يا ترى ايه أخبارك وغايب عننا ليه ؟ تقبل ودي وحبي واحترامي وتحياتي :fff:

الحمد لله أن تم المطلوب على خير لا تنسى أخي زوهير أن تحدد أفضل إجابة ليظهر الموضوع مجاب ومنتهي التزم بالتوجيهات

هل قمت بالإطلاع على المشاركة رقم 8 أخي الكريم؟ قم بتجربة الملف ووافنا بالملاحظات ...

هههههههه أخيراً فهمت تصدق اعذرني لبطء فهمي أضف فقط السطر التالي ComboBox2.Clear في بداية الحدث Private Sub ComboBox1_Change ليصبح الكود بهذا الشكل النهائي Private Sub ComboBox1_Change() ComboBox2.Clear If ComboBox1.Value = "ENTENT PREALABEL" Then ComboBox2.AddItem "APPAREILLAGE - G" ComboBox2.AddItem "APPAREILLAGE - P" ComboBox2.AddItem "REEDUCATION - F" ComboBox2.AddItem "C - T" ComboBox2.AddItem "AUTRE" End If If ComboBox1.Value = "MALADIE CRHONIQUE" Then ComboBox2.AddItem "NAUVEAU" ComboBox2.AddItem "PROLONGATION" End If End Sub أرجو ان يفي بالغرض تقبل تحياتي

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

أخي الفاضل إليك الملف التالي على قدر فهمي .. ويا ريت الأخوة المحاسبين يفيدونا لأنهم أكثر دراية مني بالأمر Sub GrabDataFromSheets() Dim WS As Worksheet, SH As Worksheet Dim Cell As Range Dim X As Long X = 7 Set SH = Sheets("كشف حساب") Application.ScreenUpdating = False SH.Range("B7:E1000").ClearContents For Each WS In ThisWorkbook.Sheets If WS.Name = "المبيعات" Or WS.Name = "المشتريات" Then For Each Cell In WS.Range("C5:C" & WS.Cells(Rows.Count, 3).End(xlUp).Row) If Cell.Value = SH.Range("C3").Value Then SH.Cells(X, 2).Value = Cell.Offset(, -1).Value SH.Cells(X, 3).Value = Cell.Offset(, 1).Value If WS.Name = "المبيعات" Then SH.Cells(X, 4).Value = Cell.Offset(, 4).Value If WS.Name = "المشتريات" Then SH.Cells(X, 5).Value = Cell.Offset(, 4).Value X = X + 1 End If Next Cell End If Next WS Application.ScreenUpdating = True End Sub تقبل تحياتي Grab Data From Two Sheets YasserKhalil.rar

الأخ الحبيب aborardia أهلا ومرحباً بك في المنتدى ونورت بين إخوانك دعوة لتغيير اسم الظهور للغة العربية اطلع على هذا الرابط لعله يفيدك http://www.officena.net/ib/index.php?showtopic=56933&hl=

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

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

أخي الفاضل المرفق غير واضح ..أرفق بعض البيانات والنتائج المتوقعة ..

بارك الله فيك أخي الحبيب ياسر هذا في وجهة نظري الحل لمشكلة اللغة العربية وإن شاء الله يفي بالغرض

الخلايا المراد أن تكون غير محمية يكفي أن تغير تنسيقها ..حدد الخلايا (أعمدة صفوف خلايا متجاورة خلايا غير متجاورة ) ثم كليك يمين ثم من التبويب Protection وأزل علامة الصح بجانب الخيار Locked وكذلك أزل علامة الصح من جانب الخيار Hidden

الأخ الكريم رجب إليك شرح الكود ، ولا تنسانا من صالح الدعاء Sub CopyRangeSpecificTimes() 'يقوم الكود بنسخ نطاق محدد إلى ورقة عمل أخرى عدد من المرات '--------------------------------------------------------- 'تعريف المتغيرات Dim WS As Worksheet, SH As Worksheet Dim I As Long, lRow As Long 'تعيين أوراق العمل ، ورقة العمل المراد النسخ منها ، وورقة العمل المراد النسخ إليها Set WS = Sheets("ورقة1"): Set SH = Sheets("ورقة2") 'تعيين صف البداية للنسخ ليكون الصف الأول lRow = 1 'إلغاء خاصية اهتزاز الشاشة Application.ScreenUpdating = False 'مسح محتويات وتنسيقات كل الخلايا في ورقة العمل المراد النسخ إليها SH.Cells.Clear 'حلقة تكرارية من 1 إلى 9 ليمثل عدد مرات النسخ For I = 1 To 9 '[Data] نسخ النطاق المسمى WS.Range("Data").Copy 'لصق البيانات المنسوخة لورقة العمل الثانية في الصف رقم 1 في أول مرة 'يتغير الصف الذي سيتم النسخ إليه [lRow] وبتغير المتغير المسمى SH.Cells(lRow, 1).PasteSpecial xlPasteAll 'زيادة المتغير بمقدار 37 ليتناسب مع عدد صفوف النطاق المنسوخ مع ترك صف فارغ lRow = lRow + 37 'إعادة عمل الحلقة التكرارية Next I 'تحديد ورقة العمل الأولى WS.Activate 'إلغاء خاصية القص والنسخ Application.CutCopyMode = False 'إعادة تفعيل خاصية اهتزاز الشاشة Application.ScreenUpdating = True End Sub تقبل تحياتي

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