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

أخي الكريم المشكلة أنك طلبت أكثر من طلب وفي حقيقة الأمر لا يمكنني العمل على أكثر من طلب في موضوع واحد إليك الكود التالي (استغرق مني وقت طويل فلا تبخل علينا بدعوة لن تستغرق مني ثواني) ...جرب الكود التالي ..قم بكتابة كود العميل ثم اضغط زر الأمر الموجود في ورقة العمل Find All Bills الكود المستخدم : Sub FindAllBills() Dim WS As Worksheet, SH As Worksheet Dim Arr, I As Long Set WS = Sheets("فاتورة"): Set SH = Sheets("استدعاء فاتورة") If IsEmpty(SH.Range("A3")) Then MsgBox "أدخل كود العميل المطلوب استدعاء فواتيره", 64: Exit Sub SH.Range("A4:N1000").Clear Arr = Split(FindRange(SH.Range("A3"), WS.Columns("C:C")), ",") For I = LBound(Arr) To UBound(Arr) On Error Resume Next WS.Range(Arr(I)).CurrentRegion.Copy SH.Range("A" & SH.Cells(Rows.Count, 1).End(3).Row + 2) Next I End Sub Function FindRange(FirstRange As Range, ListRange As Range) As String Dim aCell As Range, bCell As Range, oRange As Range Set oRange = ListRange.Find(what:=FirstRange.Value, LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) If Not oRange Is Nothing Then Set bCell = oRange: Set aCell = oRange Do Set oRange = ListRange.Find(what:=FirstRange.Value, After:=oRange, LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) If Not oRange Is Nothing Then If oRange.Address = bCell.Address Then Exit Do Set aCell = Union(aCell, oRange) Else Exit Do End If Loop FindRange = aCell.Address Else FindRange = "Not Found" End If End Function لا تنسى أن تحدد أفضل إجابة ليظهر الموضوع مجاب ومنتهي .. تقبل تحياتي Find All Bills YasserKhalil.rar

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

فكرة استخدامها بشكل أساسي هو الاحتفاظ بالقيم الفريدة أي الغير مكررة فقط ... كيفية استخدامها : هناخد الكود الخاص بحدث بدء الفورم كمثال Private Sub UserForm_Initialize() Dim Rng As Range Dim Dn As Range Dim Dic As Object With WS Set Rng = .Range(.Range("A4"), .Range("A" & Rows.Count).End(xlUp)) End With Set Dic = CreateObject("Scripting.Dictionary") Dic.CompareMode = vbTextCompare For Each Dn In Rng: Dic(Dn.Value) = Empty: Next Me.ComboBox1.List = Application.Transpose(Dic.keys) End Sub مع بداية تشغيل الفورم يتم تعبئة الكومبو الأول بالقيم الفريدة من العمود الاول الأسطر الأولى مفيش مشكلة فيها الإعلان عن المتغيرات ، تعيين النطاق ..بعدها يتم تعيين متغير من النوع كائن (اللي هو زي القاموس) وفايدته زي ما قلت إنه بيتم تخزين القيم الفريدة أي الغير مكررة فيه .. السطر الذي يليه للتعامل مع الأحرف الحساسة (السطر يتغاضى عن حالة الأحرف ... فلو كتبنا في الخلية A32 كلمة Yasser وكتبنا في الخلية A33 كلمة yasser .... وشغلنا الفورم وشوفنا القايمة المنسدلة هتلاقي أول كلمة بس هي اللي موجودة ، وتم التغاضي عن الكلمة الأخرى أي أن حالة الأحرف غير هامة ..) السطر التالي عبارة عن 3 أسطر وهو عبارة عن حلقة تكرارية For Each Dn In Rng Dic(Dn.Value) = Empty Next Dn الكائن دا شبيه بالمصفوفة بيتم تخزين عناصر فيه ولكن ميزته إنه بيخزن العنصر أو القيمة مرة واحدة فقط مع كل حلقة تكرارية .. لو اتبعت أسلوب التنقيح Debug بالضغط على F8 ستجد أنه مع كل حلقة تكرارية يتم تخزين عنصر جديد ..اسم العنصر هنا مفتاح يعني المصفوفة ليها عناصر أما الكائن القاموس ده فله مفاتيح المهم كل مفتاح مميز .. يعني يحمل قيمة واحدة فقط في السطر الأخير بيتم وضع المفاتيح في الكومبو أي تعبئة الكومبو بمفاتيح القاموس .. وطبعاً لأنها شبيهة بالمصفوفة فاستخدمنا كلمة Transpose لأن المفاتيح زي عناصر المصفوفة بتكون على شكل أفقي وعشان نخليها على شكل رأسي بنستخدم الكلمة دي .... يمكن إضافة السطر التالي لوضع مفاتيح القاموس في عمود واحد Range("G1").Resize(Dic.Count, 1).Value = Application.Transpose(Dic.keys) لاحظ هنا تم استخدام كلمة Count لعد مفاتيح القاموس .. أرجو أن أكون قد وفقت في توصيل المعلومة

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

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

بسم الله ما شاء الله أخي الحبيب خالد نشاط منقطع النظير ..بارك الله فيك ونسيت أنا موضوع الدالة Sumproduct دي نهائي .. مخطرتش ف بالي (أنا لا أحبذ معادلات الصفيف) تقبل تحياتي

بارك الله فيك أخي الحبيب خالد إليك اختصار لكود الترتيب .. Sub SortData() Application.ScreenUpdating = False Dim LR As Long ActiveSheet.Unprotect "111" LR = Range("N265").End(xlUp).Row Range("B6:BC" & LR).Sort Key1:=Range("H6:H" & LR), Order1:=xlDescending, Key2:=Range("N6:N" & LR), Order2:=xlAscending, Header:=xlNo ActiveSheet.Protect "111" Application.ScreenUpdating = True End Sub

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

ارفق ملفك بعد ما وضعت المعادلة للإطلاع عليه

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

أفضل إرفاق الملف الأصلي للإطلاع عليه .. حيث أن تكوين السطر بهذا الشكل غير منطقي .. حاول تساعد الأعضاء عشان يقدروا يساعدوك تقبل تحياتي عموماً جرب الكود التالي إذا ظبطت معاك كان بها فهي نعمة من الله إذا لم تظبط معاك فلن أساهم في الموضوع إلا بعد إرفاق الملف الأصلي (يسر علينا كي تجد المساعدة) Sub Max() Dim LR3 As Long, LR4 As Long, XX3 LR3 = 10: LR4 = 13 XX3 = Range("B11").Value Range("D7").Value = Worksheets("Seen").Evaluate("=MAX(IF(D" & LR3 & ":D" & LR4 & "= " & XX3 & ",E" & LR3 & ":E" & LR4 & "))") End Sub تقبل تحياتي

أخي الكريم أنس افتح الملف وروح لمحرر الأكواد افتح الفورم اضغط دبل كليك على الليست بوكس عشان تروح لأسطر الكود وروح في آخر الإجراء المسمى Private Sub ListBox1_Click() وقبل نهاية الإجراء أضف السطر التالي ComboBox1.Value = Me.ListBox1.List(ListBox1.ListIndex, 4)

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

أخي الكريم لم تستجب لمطلبي بتغيير اسمك للغة العربية .. ورغم عدم استجابتك لمطلبي إلا أنني استجبت لمطلبك إليك الملف التالي ..قم بالإطلاع عليه وموافاتنا بأية ملاحظات .. جرب الملف بشكل جيد بحيث لا يكون هناك توابع فيما بعد تقبل توجيهاتي وتحياتي Add Unique Items In ComboBoxes YasserKhalil.rar

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

بسم الله ما شاء الله أخي الحبيب خالد تقديم رائع لحل أروع ..بارك الله فيك تقبل وافر تقديري واحترامي

أخي الكريم يرجى الإطلاع على موضوع التوجيهات في الموضوعات المثبتة في المنتدى لمعرفة كيفية التعامل مع المنتدى بشكل أفضل يرجى تغيير اسم الظهور للغة العربية بالنسبة لطلبك : ضع معادلة الصفيف التالية في الخلية F20 =IF(SUM((D17:R17>=D16:R16)*1)=15,"نـاجح و منقول للصف الثانـي الثانوي ","له دور ثان") لا تنسى بعد وضع المعادلة يتم الضغط على Ctrl + Shift + Enter إذا واجهت خطأ قم باستبدال الفاصلة بفاصلة منقوطة , ; ولا تنسى بعد وضع المعادلة أو تحريرها أن تضغط على Ctrl + Shift + Enter لأنها معادلة صفيف لا تنسى أن تحدد أفضل إجابة ليظهر الموضوع مجاب ومنتهي تقبل توجيهاتي وتحياتي

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

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

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

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

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

أخي الحبيب أبو يوسف بالفعل كما ذكرت في حدث فتح المصنف يتم إلغاء مفتاح الهروب Esc لئلا يتحايل المستخدم ويلغي الأكواد ثم يأتي السطر التالي Application.Visible = False ويقوم السطر بإخفاء التطبيق (تطبيق الإكسيل) ثم آخر سطر يقوم بإظهار النموذج (الفورم)

راجع موضوع التوجيهات في الموضوعات المثبتة في المنتدى لعلك تعرف لما لا يوجد استجابة للموضوع

ممكن ترفق مثال بالنتائج المتوقعة (اضرب مثال) واعذرني لجهلي بمجال عملك كمحاسب