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

أخي الفاضل إليك الملف التالي تم عمل الطلب الأول بالمعادلات .. تم استخدام الدالة Vlookup بعد تسمية نطاق البيانات باسم Data أما الطلب الثاني فتم الاستغناء تماما عن ورقة العمل المسماة "قاعدة مسميات" وعمل المطلوب بالأكواد ، ولن يتأثر العمود D إلا إذا كان العمود A يحتوي على بيان فيه وإلا سوف يتم مسح البيانات حسب الكود المرفق Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Row > 1 And Target.Column = 4 Then Application.EnableEvents = False If IsEmpty(Target.Value) Or IsEmpty(Target.Offset(, -3)) Then Target.Value = "" ElseIf Target.Value = "تر" Then Target.Value = "تعديل راتب" ElseIf Target.Value = "تظ" Then Target.Value = "تظلم" ElseIf Target.Value = "اب" Then Target.Value = "إضافة بيانات" ElseIf Target.Value = "ن" Then Target.Value = "نقل" ElseIf Target.Value = "اخ" Then Target.Value = "إنهاء خدمة" ElseIf Target.Value = "ج" Then Target.Value = "أجازة" Else Target.Value = Target.Value End If Application.EnableEvents = True End If End Sub ملحوظة : لم يتم تغيير اسم الظهور .. يرجى مراجعة التوجيه الحادي عشر على هذا الرابط http://www.officena.net/ib/index.php?showtopic=60147 VLOOKUP Formula & VBA.rar

الأخ 9758412354 أهلا بك في المنتدى ونورت بين إخوانك يرجى تغيير اسمك للغة العربية كما يرجى - وأؤكد يرجى - الإطلاع على رابط التوجيهات لمعرفة القواعد المفترض السير عليها بالمنتدى http://www.officena.net/ib/index.php?showtopic=60147 وعند طرح موضوع وإرفاق ملف ، قم بضغط الملف ورفعه على سرفر المنتدى ، وليس رابط خارجي وللأخوة الكرام الذي سيقدمون المساعدة إليكم الملف المرفق في المشاركة الأولى تقبل تحياتي ملف1.rar

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

أخي الكريم طارق يوجد أسفل كل مشاركة من المشاركات كلمة "تحديد كأفضل إجابة" يتم النقر عليها في المشاركة التي أعجبتك كما يوجد كلمة "أعجبني" أيضاً .. عشان العضو اللي ساعدك ياخد نقطة .. ومعلش إذا كنت مسبب لك إزعاج ..بس دي عملية تنظيمية ليظهر الموضوع منتهي ، ويلتفت الأخوة الكرام لموضوع آخر تقبل تحياتي

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

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

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

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

أخي الفاضل سبق أن طرح الموضوع ، وقدم الأستاذ الكبير سليم حاصبيا الحل الرائع Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rng As Range For Each rng In Target.Cells If rng.HasFormula Then ActiveSheet.Protect Exit Sub Else ActiveSheet.Unprotect End If Next rng End Sub ولم ترد عليه ولم تحدد إجابته كأفضل إجابة .. بدلاً من الأكواد المنقولة حاول أن توضح طلبك بشكل أكثر تفصيلاً ... رابط الموضوع الآخر لمن هو مهتم بالأمر http://www.officena.net/ib/index.php?showtopic=60990 أمر آخر : ارفق الملف الذي تعمل عليه ويراعى عند وضع الأكواد أن تكون بين أقواس تنصيص <>

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

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

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

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

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

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

الأخ الفاضل طارق طلعت مشكور على ذكرك لاسمي ، واعلم أنني ما أنا إلا طالب علم ، واستفدت كثيراً من أساتذتي الكرام بالمنتدى ولا زلت أنهل من علمهم الغزير .. بارك الله لنا فيهم وحفظهم لنا إليك الملف التالي عله يكون المطلوب إن شاء الله لا تنسى وأكرر لا تنسى أن تحدد المشاركة التي أعجبتك كأفضل إجابة ليظهر الموضوع مجاب ومنتهي إليك الكود : Sub GrabBillData() Dim WS As Worksheet, SH As Worksheet Dim BillNo As Long, lRow As Long Set WS = Sheets("فاتورة"): Set SH = Sheets("استدعاء فاتورة") BillNo = SH.Range("A2").Value If IsEmpty(SH.Range("A2")) Then MsgBox "أدخل رقم الفاتورة المطلوب استدعائها": Exit Sub Application.ScreenUpdating = False On Error Resume Next SH.Range("A4:M1000").Clear lRow = Application.WorksheetFunction.Match(BillNo, WS.Columns("D:D"), 0) - 1 With WS .Activate .Range("A" & lRow & ":M" & .Range("A" & lRow).End(xlDown).Row).Copy SH.Range("A4") End With SH.Activate Application.ScreenUpdating = True End Sub تقبل تحياتي Grab Bill Data YasserKhalil.rar

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

هذا الشكل <> وتصبح على خير يا كبير السلام عليكم

أخي الكريم يرجى وضع الأكواد بين أقواس الأكواد لتظهر بشكل منضبط Sub Tarhil() Dim WS As Worksheet, SH As Worksheet Dim strCrt As String Dim I As Long, X As Long X = 6 Set WS = RawData: Set SH = ClientSheet strCrt = SH.Range("T1").Value Application.ScreenUpdating = False SH.Range("A6:R135").ClearContents With WS .AutoFilterMode = False For I = 6 To .Cells(4000, 1).End(xlUp).Row If .Cells(I, "S").Value = strCrt Then .Range(.Cells(I, "A"), .Cells(I, "R")).Copy SH.Range("A" & X).PasteSpecial xlPasteValues X = X + 1 End If Next I .Range("A5:R5").AutoFilter End With SH.Activate Application.CutCopyMode = False Application.ScreenUpdating = True End Sub زي كدا جرب الكود بهذا الشكل النهائي .. وإن شاء الله يكون أدى المطلوب

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

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

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

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

الموضوع غير واضح يرجى إرفاق ملف للتوضيح

أخي الفاضل إليك حل آخر باستخدام دالة معرفة UDF Function UnQ(rng As Range) As String Dim Dn As Range, n As Long, Sp As Variant With CreateObject("scripting.dictionary") .CompareMode = vbTextCompare For Each Dn In rng Sp = Split(Dn.Value, ",") For n = 0# To UBound(Sp) .Item(Sp(n)) = Empty Next n Next Dn UnQ = Join(.Keys, ",") End With End Function تقبل تحياتي Unique Values Within Range Into One Cell.rar