Yasser Fathi Albanna

سلمت يمينك الأستاذ والمعلم القدير / nedal_shami أسلوبك فى توصيل المعلومة رائع جزاك الله خير وزادك الله من العلم الكثير والكثير

سلمت يمينك الأستاذ والمعلم القدير / nedal_shami أسلوبك فى توصيل المعلومة رائع جزاك الله خير وزادك الله من العلم الكثير والكثير

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

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

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

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

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

Private Sub Worksheet_Change(ByVal Target As Range) If Me.[T1] Then Exit Sub If Not Application.Intersect(Target, Range("Yasser")) Is Nothing Then Application.EnableEvents = False Application.Undo Application.EnableEvents = True MsgBox "It is not your right to make any adjustment without reference to the Engineer / Yasser Fathi Al-Banna " End If End Sub السلام عليكم أخى الكريم هل تريد مثل المرفق ضع هذا الكود فى حدث الشيت ثم إتبع الخطوات التالية إفتح قائمة formulas ثم Name Manager ثم إختار New Name وأكتب فى الخانة Name وليكن إسم اخوك كما بالكود Yasser ثم أمام الخانة Refers To حدد الخلايا المراد حمايتها ثم إضغط OK ثم Close وجرب Book1.rar

جزاك الله خيرا

أخى الحبيب / ياسر العربى عمل متميذ وأكثر من رائع جزاك الله خيرا

اخى الحبيب / مختار إضافة رائعة جزيت بها خير يسعدنى ويشرفنى دائما مرورك

الأول إخفاء كل التبويبات وزر الأوفيس Sub hhh() Application.ExecuteExcel4Macro "show.toolbar(""ribbon"",false)" End Sub الثاني إظهار كل التبويبات وزر الأوفيس Sub sss() Application.ExecuteExcel4Macro "show.toolbar(""ribbon"",true)" End Sub

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

تقبل خالص تحياتى وتقديرى وإحترامى أخى الحبيب abouelhassan لمرورك العطر

السلام عليكم ورحمة الله وبركاته أحبائى وأساتذتى وأعضاء هذا الصرح العلمى الهائل الذى مهما قدمت له لن أوفيه حقه فيما تعلمت منه الفترة الماضية وبعد قدمت من قبل موضوع بعنوان معادلة بحث جميلة جدا على الرابط ولكن بالمعادلات اليوم أقدم لكم نفس الفكرة ولكن بالأكواد الأكواد المستخدمة الكود الأول فى حدث الشييت : Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Cells(2, 2)) Is Nothing Then: names_by_letters End Sub والكود الثانى يوضع ب Module Sub names_by_letters() Dim myRange As Range Dim i As Integer Dim x As Range i = 2 lr = Cells(Rows.Count, 1).End(xlUp).Row Range("c2:c" & lr).ClearContents Set myRange = Range("a2:a" & lr) For Each x In myRange If Mid(x, 1, 1) = [b2] Then Cells(i, 3).Value = x i = i + 1 End If Next x End Sub أرجوا أن يستفاد منه الجميع والله ولى التوفيق Find By VBA Code.rar

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

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

الله عليك يا أخى الحبيب / عبد العزيز زادك الله من علمه ومن فضلة الكثير والكثير أيوة كدا طلع المستخبى جزاك الله خير الجزاء

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

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

هل لا يوجد حل الرجاء الإفادة وأسف لكثرة إلحاحى فأنا فى أشد الإحتياج للحل وشكرا لسعة صدركم

السيد الأستاذ الفاضل / ياسر خليل هل يوجد إمكانية فى تعديل الكود الخاص بالأستاذ الفاضل / العيدروس الذى تفضلت حضرتك وقمت بالتعديل علية لينفذ العملية بسرعة ليقوم بالنتيجة المطلوبة فى المرفق عالية ولسيادتكم خالص الشكر والتقدير وشكرا لمجهود حضرتك وضياع وقتكم الثمين والكود هو Sub Test() Dim Coll As New Collection, CollDummy1 As New Collection, CollDummy2 As New Collection Dim ArrData, ArrIn, ArrOut1(), ArrOut2(), ArrOut3(), ArrOut4(), ArrCalc(), ArrTemp Dim I As Long, P As Long With Sheets("Report") ArrData = .Range("A2:F" & Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row, 2)) End With With Sheets("Rank") ArrIn = .Range("B10:B" & Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row, 10)) End With ReDim ArrOut1(1 To UBound(ArrIn, 1), 1 To 1) ReDim ArrOut2(1 To UBound(ArrIn, 1), 1 To 1) ReDim ArrOut3(1 To UBound(ArrIn, 1), 1 To 1) ReDim ArrOut4(1 To UBound(ArrIn, 1), 1 To 1) ReDim ArrCalc(1 To UBound(ArrData, 1), 1 To 2) On Error Resume Next For I = 1 To UBound(ArrData, 1) Set CollDummy1 = Nothing Set CollDummy2 = Nothing Coll.Add Key:=ArrData(I, 3), Item:=Array(Coll.Count + 1, CollDummy1, CollDummy2) ArrTemp = Coll(ArrData(I, 3)) ArrTemp(1).Add Key:=ArrData(I, 4), Item:=Empty ArrTemp(2).Add Key:=ArrData(I, 1), Item:=Empty P = ArrTemp(0) ArrCalc(P, 1) = ArrCalc(P, 1) + ArrData(I, 6) ArrCalc(P, 2) = ArrCalc(P, 2) + 1 Next I On Error GoTo 0 For I = 1 To UBound(ArrIn, 1) On Error Resume Next ArrTemp = Coll(ArrIn(I, 1)) If Err.Number = 0 Then ArrOut1(I, 1) = ArrCalc(ArrTemp(0), 1) ArrOut2(I, 1) = ArrCalc(ArrTemp(0), 2) ArrOut3(I, 1) = ArrTemp(1).Count ArrOut4(I, 1) = ArrTemp(2).Count End If On Error GoTo 0 Next I Application.ScreenUpdating = False With Sheets("Rank") .Range("D10").Resize(UBound(ArrOut1, 1), 1).Value = ArrOut1 .Range("I10").Resize(UBound(ArrOut2, 1), 1).Value = ArrOut2 .Range("N10").Resize(UBound(ArrOut3, 1), 1).Value = ArrOut3 .Range("S10").Resize(UBound(ArrOut4, 1), 1).Value = ArrOut4 End With Application.ScreenUpdating = True End Sub

الرجاء الإفادة هل الموضوع معقد الرجاء إفادتى ولسيادتكم خالص الشكر والتقدير

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

أستاذى القدير / ياسر هل طلبى حتى الأن غير واضح جزاك الله كل خير