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

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

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

بص بقا صورتك الجميلة دي زهقتني ... أنا حذفت الاختصارات من على سطح المكتب ومن على الدرايف C وغيرت صورتك لصورتي اللي باين عليها الإكسيل مش قابلها ونفذت الأمر لقيت صورتك بردو :wallbash: المهم قلت مبدهاش لازم أعمل حاجة عملت كليك يمين على الاختصار لقيت Change Icon نقرت عليها وأنا متغاااااظ .. المفاجأة لقيت الأيقونة الخاصة بالصورة بتاعتي اختارتها وفلحت .. بس أسلوب العافية ده مش بحبه عايز أعرف السبب في عدم التغيير بشكل مباشر للصورة الجديدة

اكتشفت إن لو الاختصار موجود على سطح المكتب يتم إنشاء مجلد على الدرايف C وفيه الاختصار المهم حذفت اللي على سطح المكتب وحذفت المجلد .. وتمام التمام وبعدين فتحت الملف وعدلت الصورة .. لصورتي الوحشة وانفذ الأمر الاقي الأمر اتنفذ الحمد لله :signthankspin: :dance1: متفرحش أوي يا عم ياسر الأمر اتنفذ لكن الصورة على الاختصار هي الصورة الحلوة بتاعت أخوك مختار مش صورتك الوحشة .. ييييه .. يبدو إني هنتظر رد منك ... متسبنيش أعاني وأضطر أقرا الكود حرف حرف عشان أعرف الغلطة فين ؟؟!

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

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

جرب الكود التالي عله يكون المطلوب Sub ShowFunctionArguments() Range("E7").Activate Application.SendKeys "%if" End Sub

أخي الغالي ابن الملك ولما استخدام زر ويوجد بالفعل على يسار شريط المعادلات الاختصار FX .. ما الهدف من الطلب الغريب والعجيب؟

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

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

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

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

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

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

أخي الكريم أما آن لك أن تقوم بتغيير اسم الظهور للغة العربية مسألتك في منتهى البساطة وليس لها علاقة بالكود ... في الملف يوجد تنسيق شرطي ..يمكنك الإطلاع عليه من التبويب Data ثم الأمر Conditional Formatting واختار Manage Rules ستجد معادلة التنسيق بهذا الشكل =NOT(ISBLANK(A6)) وتعني إذا لم تكن الخلية في العمود الأول فارغة يتم التنسيق بالشكل المطلوب وبجانب المعادلة يوجد النطاق الذي سيتم تطبيق التنسيق عليه قم بتعديل النطاق ليناسب الأعمدة التي تريدها =$A$6:$I$40 لا تنسى أن تحدد أفضل إجابة وأن تضغط على كلمة "أعجبني هذا" وأن تلتزم بالتوجيهات والنصائح المقدمة لك من الأخوة الأعضاء (يا مستر تويوتا)

أخي الكريم عبد الواحد بعد فتح الملف بكلمة السر المميزة للأخين محمد حسن وعلاء رسلان (علامة النجمة) روح للأمر Save As حفظ باسم واختار تنسيق الملف Xlsm نفس التنسيق القديم وبجانب كلمة Save ستجد كلمة Tools بجانبها سهم صغير (ممكن تستخدم عدسة مكبرة عشان السهم صغير) انقر السهم هتلاقي General Options أي خيارات عامة انقر عليها واحذف كلمة السر واضغط Ok ثم أخيراً Save لو هتحفظ الملف في نفس المسار هيظهر لك رسالة تأكيد الاستبدال .. اضغط Yes للموافقة على الاستبدال أو غير اسم الملف الجديد باسم تاني وخلي القديم بكلمة السر زي ما هو (زي ما تحب .. تاكل سوداني أو تأزأز لب)

أخي الحبيب علاء بدلاً من استخدام جدول للنوع يمكن تعديل المعادلة لتؤدي الغرض بهذا الشكل بدون الاستعانة بجدول =VLOOKUP(A2,{"ذكر","ي";"أنثى","ت"},2,0)&IF(H2>=16,"وجه",IF(AND(G2>=10,H2<16),"نتقل","عيد السنة"))

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

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

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

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

تفضل أخي الكريم اشرف التعديل الأخير Public Function Wish(RngData As Range, RngWish As Range, Start_WishColumn As Long, End_WishColumn, MarkColumn As Long, MinimumMark As Single) 'البارامتر الأول يمثل نطاق البيانات بالكامل 'البارامتر الثاني يمثل نطاق الرغبات والحد الأقصى المسموح به 'البارامتر الثالث يمثل رقم عمود بداية الرغبات ضمن النطاق 'البارامتر الرابع يمثل رقم عمود نهاية الرغبات ضمن النطاق 'البارامتر الخامس يمثل رقم عمود الدرجات ضمن النطاق 'البارامتر السادس يمثل الدرجة الصغرى والناتج يكون بدون توجيه '=Wish(D8:R27,U12:V23,3,14,15,10) '----------------------------------------------------------- Dim ArrData, ArrWish, ArrOut, ArrSwap Dim ColCount As Long, I As Long, J As Long, K As Long ArrData = RngData.Value ArrWish = RngWish.Value For I = 1 To UBound(ArrWish, 1) ArrWish(I, 2) = ArrWish(I, 2) Next I ReDim ArrOut(1 To UBound(ArrData, 1), 1 To 1) ColCount = UBound(ArrData, 2) ReDim ArrSwap(1 To 1, 1 To ColCount) For I = 1 To (UBound(ArrData, 1) - 1) For K = I To UBound(ArrData, 1) If ArrData(K, MarkColumn) > ArrData(I, MarkColumn) Then For J = 1 To ColCount ArrSwap(1, J) = ArrData(I, J) ArrData(I, J) = ArrData(K, J) ArrData(K, J) = ArrSwap(1, J) Next J End If Next K Next I For I = 1 To UBound(ArrData, 1) If ArrData(I, MarkColumn) < MinimumMark Then ArrOut(I, 1) = "بدون توجيه" Else For J = Start_WishColumn To End_WishColumn If ArrOut(I, 1) = "" Then For K = 1 To UBound(ArrWish, 1) If ArrData(I, J) = ArrWish(K, 1) Then If ArrWish(K, 2) > 0 Then ArrOut(I, 1) = ArrWish(K, 1) ArrWish(K, 2) = ArrWish(K, 2) - 1 End If End If Next K End If Next J End If Next I For I = 1 To (UBound(ArrData, 1) - 1) For K = I To UBound(ArrData, 1) If ArrData(K, 1) < ArrData(I, 1) Then ArrSwap(1, 1) = ArrData(I, 1): ArrSwap(1, 2) = ArrOut(I, 1) ArrData(I, 1) = ArrData(K, 1): ArrOut(I, 1) = ArrOut(K, 1) ArrData(K, 1) = ArrSwap(1, 1): ArrOut(K, 1) = ArrSwap(1, 2) End If Next K Next I Wish = ArrOut End Function

عموماً إليك الكود التالي عله يفي بالغرض إن شاء المولى Sub Test() Dim Coll As New Collection, ArrSheet, ArrTemp, ArrHolder, ArrOut1, ArrOut2 Dim I As Long, J As Long, P As Long, P1 As Long, P2 As Long, Str1 As String ArrSheet = Array(Sheets("مباع"), Sheets("مفعل"), Sheets("active"), Sheets("راجع")) ReDim ArrHolder(1 To Rows.Count, 1 To (UBound(ArrSheet) + 2)) ReDim ArrOut1(1 To Rows.Count, 1 To 1) ReDim ArrOut2(1 To Rows.Count, 1 To 1) For J = LBound(ArrSheet) To UBound(ArrSheet) ArrTemp = ArrSheet(J).Range("A2").CurrentRegion.Columns(1).Value On Error Resume Next For I = 1 To UBound(ArrTemp, 1) Str1 = CStr(ArrTemp(I, 1)) Coll.Add Key:=Str1, Item:=Coll.Count + 1 P = Coll(Str1) ArrHolder(P, 1) = ArrTemp(I, 1) ArrHolder(P, J + 2) = ArrHolder(P, J + 2) + 1 Next I On Error GoTo 0 Next J For I = 1 To Coll.Count P = 0 For J = 2 To UBound(ArrHolder, 2) P = P + Sgn(ArrHolder(I, J)) Next J If (P = UBound(ArrSheet) + 1) Then P1 = P1 + 1 ArrOut1(P1, 1) = ArrHolder(I, 1) Else P2 = P2 + 1 ArrOut2(P2, 1) = ArrHolder(I, 1) End If Next I With Sheets("النتيجة المطلوبة") .Range("A2").Resize(P1).Value = ArrOut1 .Range("B2").Resize(P2).Value = ArrOut2 End With End Sub سيتم استخراج الأرقام المتشابهة في كل أوراق العمل الأربعة معاً في العمود الأول أما الأرقام التي لم تحقق الشرط ستكون في العمود الثاني في ورقة العمل الأخيرة لا تنسى أن تحدد أفضل إجابة وأن تضغط على كلمة "أعجبني هذا" في حالة أن أعجبك الحل تقبل تحياتي Similar Data In Multi Sheets YasserKhalil.rar

بارك الله فيك أخي وحبيبي في الله خالد الرشيدي معادلة في منتهى الجمال والروعة زيادة في الخير وإثراءً للموضوع أقدم لكم حل بدالة معرفة والدالة للعلامة الكبير عبد الله باقشير - غفر الله لنا وله - Function Kh_Names(FullName As String, ParamArray Index1()) As String Dim I As Integer Dim Kh_Split, MyArray, Arr 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 Arr In MyArray RE = Replace(Arr, " ", "^") SN = Replace(SN, Arr, 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 استخدام الدالة =Kh_Names($F2,COLUMN(A$1)) أو يمكن بهذا الشكل =Kh_Names($F2,1) الرقم 1 يمثل الاسم الأول .. استخدم نفس المعادلة واستبدل الرقم 1 برقم 2 لاستخراج الاسم الثاني وهكذا تقبلوا تحياتي :fff: Split Compound Names.rar

وضح بملف مرفق حيث أنني لم أفهم مقصودك أخي الكريم اشرف