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

على رسلك أخي الحبيب علاء رسلان فربما لم يمر الأمر بك أو أن الأمر حديث عهد بالرياضيات عموماً ضع الزاوية الأولى في الخلية A1 والزاوية الثانية في الخلية B1 ثم جرب في الخلية C1 المعادلة التالية علها تفي بالغرض =IF(SIN(A1-B1)>0,(A1+B1)/2,(A1+B1+360)/2) يا عاشق الرياضيات .. لك قرين يعشق الرياضيات (اللي هو العبد لله) بس طبعاً مستوايا لا يرقى أبداً إلى مستواك تقبل تحياتي وحبي واحترامي

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

أخي الحبيب طالما أنك تريد إظهار خيارات لما لا تستخدم القائمة المنسدلة المخصصة لهذا الأمر؟

أخي الكريم أبو حنين الملف كبير الحجم ويستغرق وقت طويل في الفتح ويعطي رسائل خطأ مرتبطة بخطأ في الأكواد في موديول 1 والمحرر مغلق بكلمة سر .. يرجى حذف الأوراق الغير مرتبطة بالطلب حتى يخف حجم الملف وإرفاق الملف مفتوح المصدر بدون كلمة سر لمحرر الأكواد

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

حدد العمود ثم اذهب للتبويب Data ستجد الأمر Remove Duplicates

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

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

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

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

أخي الحبيب علاء رسلان عشرات من فنجايل القهوة .. ومفيش مرة فيهم تعزمني على واحد .. مشكور يا كبير إليك حل مشابه للحل الذي قدمته في المشاركة رقم 11 إلا أنه لا يعتمد على نطاق ثابت بل إنه يتم إنشاء النطاق الخاص بالشروط في آخر الأعمدة في ورقة العمل التي تظهر فيها النتائج ثم بعد تنفيذ الكود يتم مسح البيانات لجدول الشروط .. التصفية المتقدمة أسهل الطرق وأيسرها لتنفيذ المطلوب .. إذا كانت الخلية فارغة لأي خلية من خلايا الشرط فهذا يعني أنه يتم جلب كل البيانات بدون اللجوء إلى كلمة " الكل" أو خلافه ... جرب تترك كل الخلايا B2 و B3 و H2 و H3 فارغة .. ونفذ الكود ستجد أن البيانات جميعها يتم جلبها ... ولو اخترت أي شرط سيتم جلب البيانات المرتبطة بهذا الشرط إليك الكود مع شرح لأسطر الكود لعله يروي ظمأك Sub AdvancedFilterUsingConditionsArray() 'يقوم الكود بالتصفية المتقدمة للبيانات بشروط والشروط لا توجد في نطاق بل يتم إنشائها ثم مسحها '------------------------------------------------------------------------------------------ Dim LastRow As Long, Rng As Range, Header, Criteria, I As Long 'بدء التعامل مع ورقة النتائج المطلوب فيها فرز البيانات With Sheets("التقرير") 'تعيين آخر صف به بيانات في ورقة البيانات الرئيسية LastRow = Sheets("التوريدات").Cells(Rows.Count, "A").End(xlUp).Row 'وضع عناوين الشروط Header = Array("وارد لقطاع", "الصنف", "اسم المورد", "رقم LPO") 'تحديد النطاق الذي ستوضع به الشروط Set Rng = .Cells(1, Columns.Count).Offset(, -UBound(Header)).Resize(, UBound(Header) + 1) 'النطاق يساوي عناوين الشروط Rng.Value = Header 'تعيين الشروط في الخلايا المحددة داخل المصفوفة Criteria = Array("B2", "B3", "H2", "H3") 'حلقة تكرارية للشروط For I = LBound(Criteria) To UBound(Criteria) 'إذا كانت الخلية التي بها الشرط فارغة يتم إضافة علامة لا يساوي وإلا يظل الشرط كما هو Criteria(I) = IIf(.Range(Criteria(I)) = "", "<>", .Range(Criteria(I))) Next I 'النطاق الذي ستوضع به الشروط في الصف التالي توضع به الشروط الجديدة Rng.Offset(1).Value = Criteria 'التعامل مع ورقة البيانات الرئيسية لعمل التصفية المتقدمة Sheets("التوريدات").Range("A4:I" & LastRow).AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=Rng.CurrentRegion, _ CopyToRange:=.Range("A4:H4"), Unique:=True 'مسح النطاق الذي تم وضع الشروط به Rng.CurrentRegion.ClearContents End With End Sub أرجو أن يكون الكود مفيد تقبل تحياتي Advanced Filter Without Criteria Table.rar

أخي العزيز عزيز البيانات راحت تفطر عشان كانت صايمة طول النهار وهيست ههههه يمكنك الدخول لمحرر الأكواد ومن نافذة المشروع ستجد أوراق العمل .. ورقة العمل التي تقصدها مخفية يمكنك إظهارها من نافذة الخصائص من خلال الخاصية Visible اختر الخيار XlsheetVisible وها هو الملف المرفق وبه ورقة العمل المخفية تقبل تحياتي وهزاري Codes Library.rar

أخي الكريم أهلا بك ومرحباُ في المنتدى يرجى الإطلاع على التوجيهات من هذا الرابط كما يرجى تغيير اسم الظهور للغة العربية يرجى إرفاق ملف بعد ضغطه للإطلاع عليه ومحاولة مساعدتك إن شاء الله يمكنك الإطلاع على هذا الملف عله يفيدك الكود المرفق بالملف يقوم بتجميع البيانات من أوراق عمل محددة مسبقاً داخل الكود Collect Data From Sheets.rar

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

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

أخي الكريم يرجى تغيير اسم الظهور للغة العربية كما يرجى الإطلاع على رابط التوجيهات لمعرفة كيفية التعامل مع المنتدى إليك المعادلة التالية لتحقق المطلوب إن شاء الله =CHOOSE(MATCH($F$4,Stores,0),خامات1,قطاعات1) وإليك الملف المرفق فيه تطبيق المعادلة تقبل تحياتي Dynamic Ranges & Data Validation List.rar

شكلها هتولع .. :yes: اجتماع الكبار والعمالقة ... أ / محمد صالح ، و أ / أسامة البراوي يلا عايزين نشوف حاجة جديدة ومميزة .. نريد خطوة على طريق التقدم فيما يخص هذا الموضوع ؛ ليكون بصمة كبيرة في المنتدى

أخي الغالي زوهير بارك الله فيك على هذا الكود الرائع تم إضافة سطر واحد في نهاية الكود لتلبية الطلب الأخير للأخ أكرم جلال Private Sub UserForm_Initialize() Dim Z As Integer For Z = 1 To Range("A5000").End(xlUp).Row ComboBox1 = Range("A" & Z) If ComboBox1.ListIndex = -1 Then ComboBox1.AddItem Range("A" & Z) Next Z If ComboBox1.ListCount > 0 Then ComboBox1.ListIndex = 0 End Sub أو يمكن استبدال السطر الأخير بهذا السطر مباشرةً ComboBox1.ListIndex = 0 تقبلوا تحياتي

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

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

أخي الكريم سليم هل حملت المرفق في المشاركة رقم 4؟ حمل المرفق وأعملني بالنتيجة ..

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

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

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

أخي الكريم فراس إليك الكود التالي عله يفي بالغرض إن شاء المولى Sub ExtractTwoNames() 'يقوم الكود باستخراج الأسماء الفردية و الثنائية ويضع النتائج في العمود الثاني '---------------------------------------------------------------------------- Dim Rng As Range, Cell As Range Dim lRow As Long Set Rng = Range("A2:A" & Cells(Rows.Count, 1).End(3).Row) lRow = 2 Application.ScreenUpdating = False For Each Cell In Rng If kh_Names(Trim(Cell.Value), 1) = Trim(Cell.Value) Or kh_Names(Trim(Cell.Value), 1, 2) = Trim(Cell.Value) Then Cells(lRow, 2) = Trim(Cell): lRow = lRow + 1 Next Cell Application.ScreenUpdating = True End Sub Function kh_Names(FullName As String, ParamArray iNdex1()) As String Dim I As Integer Dim kh_Split, MyArray, Ar Dim Kh_String As String, Sn As String, Re As String On Error GoTo Err_Kh_Names MyArray = Array("عبد ", "أبو ", "ابو ", "آل ", " الله", " الدين", " الإسلام", " الاسلام", " الحق", " النصر", " العهد", " النور", " بالله") Sn = Application.WorksheetFunction.Trim(FullName) For Each Ar In MyArray Re = Replace(Ar, " ", "^") Sn = Replace(Sn, Ar, Re) Next kh_Split = Split(Sn, " ", , vbTextCompare) On Error Resume Next For I = 0 To UBound(iNdex1) Kh_String = Kh_String & " " & kh_Split(iNdex1(I) - 1) Next On Error GoTo 0 Kh_String = Replace(Trim(Kh_String), "^", " ") kh_Names = Kh_String Exit Function Err_Kh_Names: kh_Names = "" End Function تقبل تحياتي :fff: لا تنسى أن تحدد أفضل إجابة وتضغط أعجبني (هتعمل حاجتين مش حاجة واحدة) Extract Single & Double Names YasserKhalil.rar