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

تفضل أخي الكريم حيث أن الملف مفيد للطلبة و ضمن المناهج الأكاديمية 2.xls

عذرا طلبك واضح ولكنى لم انتبه عن طريق كود كتابة اسماء الفصول بالارقام العربية.xlsb

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

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

الملف في الرد السابق

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

معلمي وأستاذي الفاضل / محمد صالح السلام عليكم ورحمة الله وبركاته لقد أثلج صدري تعليقكم الذي هو بمثابة بلسم يداوي الجروح ولكن أحببنا فقط أن نلفت الانتباه لحسن الأسلوب في التوجيه لما قد نغفل عنه أحيانا دون قصد أو عمد. ولنا في سيدنا رسول الله (صل الله عليه وسلم) أسوة حسنة حينما قال ربنا سبحانه وتعالى في محكم كتابه الكريم قرآنا يتلى إلى أن يرث الله الأرض ومن عليها في حق رسولنا الكريم: (فَبِمَا رَحۡمَةٖ مِّنَ ٱللَّهِ لِنتَ لَهُمۡۖ وَلَوۡ كُنتَ فَظًّا غَلِيظَ ٱلۡقَلۡبِ لَٱنفَضُّواْ مِنۡ حَوۡلِكَۖ ...) آل عمران (159) § ولله الحمد والمنة أنه تم استبدال عبارة (أفضل إجابة) بعبارة (تمت الإجابة) فكل من أدلى بدلوه يستحق كل الشكر وعظيم الاحترام والتقدير؛ وكوني كنت معلما فأعرف للمعلم قدره جيدا وتبجليه؛ ولله در الشاعر (أحمد شوقي) حينما قال: قُم لِلمُعَلِّمِ وَفِّهِ التَبجيلا ... كادَ المُعَلِّمُ أَن يَكونَ رَسولا أَعَلِمتَ أَشرَفَ أَو أَجَلَّ مِنَ الَّذي ... يَبني وَيُنشِئُ أَنفُساً وَعُقولا سُبحانَكَ اللَهُمَّ خَيرَ مُعَلِّمٍ ... عَلَّمتَ بِالقَلَمِ القُرونَ الأولى § وأشهد الله أن في هذا المنتدى المحبب إلى قلبي ونفسي من جاوبنا وعلمنا ما جهلنا دون أن يعرف بعضنا بعضا بصفة شخصية؛ وإن تقابلت الوجوه يوما ما لقبلت رؤوسهم وأيديهم تقديرا واحتراما لفضلهم علينا وكيف لا و (من علمني حرفا صرت له عبدا) وأذكر منهم: ü الأستاذ الفاضل / ابراهيم الحداد ü الأستاذ الفاضل / محمد صالح ü الأستاذ الفاضل / Ali Mohamed Ali ü الأستاذ الفاضل / محمد هشام. ü الأستاذ الفاضل / عبدالله بشير عبدالله فلكم جميعا مني كل الشكر و التقدير والاحترام وجزاكم الله عنا خير الجزاء. v أستاذي الفاضل / محمد صالح ما أجمل قولك حينما ختمت أحد موضوعاتك الرائعة: لو بخل بها غيرك ما وصلت إليك ... فلا تبخل بها على غيرك بعد معرفتك بها v وأذكر في هذا المقام: · (... عن علمه فيما عمل به ...) · (تعلم فليس المرء يولد عالما ... وليس أخو علم كمن هو جاهل) v أما وإن ذكرت قول الله تعالى: (... وَلۡيَعۡفُواْ وَلۡيَصۡفَحُوٓاْۗ أَلَا تُحِبُّونَ أَن يَغۡفِرَ ٱللَّهُ لَكُمۡۚ وَٱللَّهُ غَفُورٞ رَّحِيمٌ) النور (22) فقد عفونا. (انتهى)

السلام عليكم ورحمة الله وبركاته أستاذ الفاضل @algammal علمناك دائما واسع الصدر طويل البال ولا يختلف أحد على عزة نفس الجميع في هذا الصرح وحضرتك أولهم وكلنا يتواصل مع الأصدقاء في هذا الصرح بروحه لأننا ربما لا نعرف بعضنا معرفة شخصية في الواقع ولذا نلتمس لبعضنا العذر في اختلاف الثقافات والبيئات فلا أعتقد أن الصديق الذي ارسل لحضرتك هذه الرسالة يقصد الإساءة لحضرتك ولكنه يقصد فقط أن نتعاون جميعا ويدعم بعضنا بعضا ونكون سببا في الارتقاء بأنفسنا واعذرني في تحليلي لنص الرسالة بطريقة مختلفة: الأخ صاحب الرسالة يريدك فقط أن تدعم من قام بالإجابة بالضغط على زر الإعجاب وزر أفضل إجابة (وهذه نواحي تنظيمية لمحتوى المنتدى) وهو مما يزيد شعبية من أجاب طلب حضرتك وترتيبه في المنتدى وكل هذا دعما معنويا للمجيب. ومن باب هل جزاء الإحسان إلا الإحسان كلنا ندعم صاحب الرد الجميل بالإعجاب حتى وإن لم يكن أفضل إجابة. وفي الأخير أذكر نفسي وجميع اصدقائي بقول الله تعالى: وَلْيَعْفُوا وَلْيَصْفَحُوا ۗ أَلَا تُحِبُّونَ أَن يَغْفِرَ اللَّهُ لَكُمْ ۗ وَاللَّهُ غَفُورٌ رَّحِيمٌ. جعلنا الله جميعا ممن يحسنون الحديث ويقولون قولا يسلمون فيه من الاثم والأذى وكل عام وأنتم جميعا بخير وصحة وسعادة

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

تفضل جرب هذا Employees Form-unprotected - Copy.xlsm

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

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

العفو أخي الكريم يسعدنا أننا إستطعنا مساعدتك إليك طريقة أخرى مع إظافة التنسيقات يمكنك إختيار ما يناسبك Option Explicit Sub Extract_Names2() Dim dict As Object, ColA As Range, ColB As Range, a As Variant, b As Variant Dim tbl As String, Key As Variant, ColE As Long, début As Long, lr As Long, tmp As Range Dim dCount As Long, UniCount As Long, i As Long, Irow As Long, AutoFilterWasOn As Boolean Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") With Application: .ScreenUpdating = False: .Calculation = xlCalculationManual: End With AutoFilterWasOn = CrWS.AutoFilterMode If AutoFilterWasOn Then CrWS.AutoFilterMode = False lr = Application.WorksheetFunction.Max(CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row, _ CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row) With CrWS.Range("D2:E" & CrWS.Rows.Count) .ClearContents: .Borders.LineStyle = xlNone End With Set dict = CreateObject("Scripting.Dictionary"): dict.CompareMode = vbTextCompare Set ColA = CrWS.Range("A3:A" & lr): Set ColB = CrWS.Range("B3:B" & lr) For Each tmp In ColB tbl = tmp.Value If Not dict.exists(tbl) Then dict.Add tbl, 1 Else dict(tbl) = dict(tbl) + 1 Next tmp début = 3: dCount = 0 For Each tmp In ColA tbl = tmp.Value If dict.exists(tbl) Then CrWS.Cells(début, 4).Value = tbl CrWS.Cells(début, 5).Value = tbl dict.Remove tbl: début = début + 1: dCount = dCount + 1 End If Next tmp ColE = Application.WorksheetFunction.Max(début, CrWS.Cells(Rows.Count, 5).End(xlUp).Row + 1) UniCount = 0 For Each Key In dict.Keys CrWS.Cells(ColE, 5).Value = Key ColE = ColE + 1: UniCount = UniCount + 1 Next Key CrWS.Range("D2").Value = "عدد الوظائف المتشابهة: " & dCount & " | عدد الوظائف الفردية: " & UniCount CrWS.Columns("D:E").AutoFit On Error Resume Next CrWS.Range("D3:E" & CrWS.UsedRange.Rows.Count).FormatConditions.Delete On Error GoTo 0 With CrWS.Range("D3:E" & CrWS.UsedRange.Rows.Count) .FormatConditions.Add Type:=xlExpression, _ Formula1:="=AND(D3<>"""", COUNTIF($D$3:$E$" & .Rows.Count & ", D3)>1)" .FormatConditions(1).Font.Color = RGB(255, 0, 0): .FormatConditions(1).Interior.Color = RGB(255, 182, 193) End With Irow = Application.WorksheetFunction.Max( _ CrWS.Cells(CrWS.Rows.Count, "D").End(xlUp).Row, CrWS.Cells(CrWS.Rows.Count, "E").End(xlUp).Row) a = CrWS.Range("D3:D" & Irow).Value: b = CrWS.Range("E3:E" & Irow).Value For i = 1 To UBound(a, 1) If a(i, 1) <> "" Then With CrWS.Cells(i + 2, 4).Borders .LineStyle = xlContinuous: .Weight = xlThin: .ColorIndex = xlAutomatic End With End If If b(i, 1) <> "" Then With CrWS.Cells(i + 2, 5).Borders .LineStyle = xlContinuous: .Weight = xlThin: .ColorIndex = xlAutomatic End With End If Next i With Application: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: End With End Sub Book2 v4.xlsb

يمكننا أخي تعديل الكود ليتناسب مع طلبك لاكن لاحظت انه هناك أسماء متشابهة الفرق الوحيد بينها هو المسافات كما في المثال الموضح في الصورة أسفله إدا كنت تعتبر أنها أسماء متشابهة يجب جلبها أمام بعضها البعض فالكود التالي ربما سيوفي بالغرض Option Explicit Sub Extract_Names() Dim dCount As Long, UniCount As Long, AutoFilterWasOn As Boolean Dim Ons As Object, tbl As String, dict As Object, _ début As Long, lr As Long, tmp As Range, Key As Variant Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") With Application: .ScreenUpdating = False: .Calculation = xlCalculationManual: End With AutoFilterWasOn = CrWS.AutoFilterMode If AutoFilterWasOn Then CrWS.AutoFilterMode = False lr = Application.WorksheetFunction.Max(CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row, _ CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row) Set dict = CreateObject("Scripting.Dictionary") dict.CompareMode = vbTextCompare Set Ons = CreateObject("Scripting.Dictionary") Ons.CompareMode = vbTextCompare For Each tmp In CrWS.Range("B3:B" & lr) If Not IsEmpty(tmp.Value) Then tbl = Replace(Trim(tmp.Value), " ", "") If Not dict.exists(tbl) Then dict.Add tbl, tmp.Row If Not Ons.exists(tbl) Then Ons.Add tbl, tmp.Row End If Next tmp CrWS.Range("D2:E" & CrWS.Rows.Count).ClearContents début = 3: dCount = 0: UniCount = 0 For Each tmp In CrWS.Range("A3:A" & lr) If Not IsEmpty(tmp.Value) Then tbl = Replace(Trim(tmp.Value), " ", "") If dict.exists(tbl) Then CrWS.Cells(début, 4).Value = tmp.Value CrWS.Cells(début, 5).Value = CrWS.Cells(dict(tbl), 2).Value dict.Remove tbl: Ons.Remove tbl: début = début + 1: dCount = dCount + 1 End If End If Next tmp For Each Key In Ons.keys CrWS.Cells(début, 5).Value = CrWS.Cells(Ons(Key), 2).Value début = début + 1: UniCount = UniCount + 1 Next Key CrWS.Range("D2").Value = "عدد الوظائف المتشابهة: " & dCount & " | عدد الوظائف الفردية: " & UniCount CrWS.Columns("D:E").AutoFit With Application: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: End With End Sub Book2 v3.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته أخي @M.Elmahmoudy رغم أن طلبك غير واضح تماما بالنسبة لي لاكن بعد معاينة الملف على حسب ما فهمت أعتقد أن الحل الأمثل لتنفيد طلبك هو إستخدام الأكواد لأنها سوف تضمن لك الدقة في النتائج والسرعة في التنفيد لأن المعادلات غير قادرة على تنفيذ جميع الوظائف بنفس الكفاءة خصوصا عند التعامل مع قوائم غير مرتبة وتكرار القيم ونطاقات غير المتساوية ولا ربما صفوف مخفية عند تنفيد الفرز على عمود معين زيادة على بطئ ملحوظ في الأداء عند وجود بيانات كبيرة يمكنك تجربة هدا وإذا كنت بحاجة إلى أي تعديلات إضافية يمكنني محاولة مساعدتك في ذلك Option Explicit Sub Extract_Names() Dim dict As Object, début As Long, lr As Long, tmp As Range, AutoFilterWasOn As Boolean Dim dCount As Long, UniCount As Long, ColA As Range, ColB As Range Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") With Application .ScreenUpdating = False: .Calculation = xlCalculationManual End With AutoFilterWasOn = CrWS.AutoFilterMode If AutoFilterWasOn Then CrWS.AutoFilterMode = False lr = Application.WorksheetFunction.Max(CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row, _ CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row) Set dict = CreateObject("Scripting.Dictionary") Set ColA = CrWS.Range("A3:A" & lr): Set ColB = CrWS.Range("B3:B" & lr) For Each tmp In ColB If Not dict.exists(tmp.Value) Then dict.Add tmp.Value, tmp.Row Next tmp CrWS.Range("C2:C" & CrWS.Cells(CrWS.Rows.Count, 3).End(xlUp).Row).ClearContents début = 3: dCount = 0: UniCount = 0 For Each tmp In ColA If dict.exists(tmp.Value) Then CrWS.Cells(début, 3).Value = tmp.Value & " / " & CrWS.Cells(dict(tmp.Value), 2).Value dict.Remove tmp.Value début = début + 1 dCount = dCount + 1 End If Next tmp For Each tmp In ColB If dict.exists(tmp.Value) Then CrWS.Cells(début, 3).Value = tmp.Value début = début + 1 UniCount = UniCount + 1 End If Next tmp CrWS.Range("C2").Value = " عدد الوظائف / المتشابهة: " & dCount & " & الفردية: " & UniCount CrWS.Columns("C:C").EntireColumn.AutoFit Set dict = Nothing With Application .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub Book2 v2.xlsb