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

وعليكم السلام أخي صالح أهلاً بك في المنتدى ونورت بين إخوانك يرجى تغيير اسم الظهور للغة العربية بالنسبة لطلبك ضع المعادلة التالية في الخلية D2 =IF($B2-$C2>=1000,1000,$B2-$C2) ثم ضع المعادلة التالية في الخلية E2 =IF($D2>=1000,($B2-$D2)/4,"") قم بسحب المعادلة الأخيرة التي في الخلية E2 إلى الخلية H2 الآن قم بتحديد النطاق D2:H2 ثم قم بسحب المعادلات إلى آخر الجدول ** إذا صادفتك مشكلة قم بتحويل الفاصلة العادية لفاصلة منقوطة تقبل تحياتي

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

الحمد لله الذي بنعمته تتم الصالحات والحمد لله أن تم المطلوب على خير تقبل تحياتي

تفضل أخي الكريم وجرب الملف التالي Baraa Record V2.rar

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

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

أخي الكريم الحسام يوجد ورقة عمل مخفية باسم Conditions ، قم بإظهارها من خلال محرر الأكواد Alt + F11 وروح للخصائص الخاصة بهذا الشيت ..أي حدد الشيت من نافذة المشروع ، ومن نافذة الخصائص قم بإظهار ورقة العمل من الخاصية Visible اجعلها xlSheetVisiible تاني خطوة عدل نطاق الفصول من النطاق F14 لتزيد الفصول كما تريد .. وليكن 13 فصل ..إذاً ستقوم بكتابة الفصول من 1 إلى 13 أي من النطاق F14 إلى F26 الآن اذهب للتبويب Formulas ثم Name Manager ثم اختر النطاق المسمى ClassList ثم انقر Edit لتعديل مدى النطاق ، ستعدل رقم 18 إلى 26 ليشمل جميع الفصول ....

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

بارك الله فيك أخي أبو تامر كود جميل .. بالنسبة للنتائج لا تظهر منضطبة في بعض الأحيان في خلايا معينة وهي التي تكون منفردة (حيث تختفي علامة الدولار) مثال الصف رقم 3 حيث القيمة 0.17 بينما لم يظهر معها علامة الدولار إليكم حل آخر بدالة معرفة تقوم بجلب نص محدد من داخل الخلية Function GetElement(Str As String, Delim As String, Ordinal As Long) As Variant Dim strTxt() As String If Len(Str) = 0 Then GetElement = CVErr(xlErrNA) Exit Function End If If Len(Delim) > 1 Then GetElement = CVErr(xlErrNA) Exit Function End If If InStr(1, Str, Delim) = 0 Then GetElement = CVErr(xlErrNA) Exit Function End If If Ordinal <= 0 Then GetElement = CVErr(xlErrNA) Exit Function End If If Ordinal > Len(Str) - Len(Replace(Str, Delim, vbNullString)) + 1 Then GetElement = CVErr(xlErrNA) Exit Function End If strTxt = Split(Str, Delim) GetElement = Application.WorksheetFunction.Trim(strTxt(Ordinal - 1)) End Function استخدام الدالة : استخدم المعادلتين التاليتين : =GetElement(B2,")",1)&")" والثانية =GetElement(B2,")",2) أما فيما يخص الملف المرفق فأنا لا أرفق ملفات حتى يتعود الأعضاء تطبيق الحلول بأنفسهم .. وذلك لنرتقي ونتعلم تقبلوا تحياتي

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

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

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

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

ابحث في المنتدى عن تحويل الملف إلى ملف تنفيذي وستجد الشرح بالتفصيل ..

هلا أرفقت ملف للعمل عليه ومحاولة تقديم المساعدة إذا أمكن

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

أخي الكريم سامح قم بفك الضغط عن ملفاتك ثم ضع الأربعة ملفات داخل مجلد وليكن باسم Sameh الآن قم بفتح المصنف المسمى Total ثم اضغط من لوحة المفاتيح Alt + F11 للدخول لمحرر الأكواد ثم من قائمة Insert قم بإدراج موديول جديد Module ضع الكود التالي في الموديول الذي تم إدراجه 'https://www.officena.net/ib/topic/71793-* '========================================= Sub Test() Dim coll As New Collection, rngSrc As Range, rngTgt As Range, arr(), arrTemp() Dim I As Long, J As Long, P As Long, strKey As String, v Set rngSrc = ThisWorkbook.Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 13) Set rngSrc = rngSrc.Offset(1).Resize(rngSrc.Rows.Count - 2) rngSrc.Columns("D:F").ClearContents rngSrc.Columns("K:M").ClearContents arr = rngSrc.Value For I = 1 To UBound(arr, 1) On Error Resume Next coll.Add Key:="LEFT" & arr(I, 2), Item:=I coll.Add Key:="RIGHT" & arr(I, 9), Item:=I On Error GoTo 0 Next I Application.ScreenUpdating = False v = Dir(ThisWorkbook.Path & "\*.xlsx") While v <> "" With Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & v, ReadOnly:=True) With .Sheets("Summary Report ").UsedRange Set rngTgt = .Find(What:="Driver Name", After:=.Cells(.Rows.Count, .Columns.Count)) If Not rngTgt Is Nothing Then arrTemp = rngTgt.CurrentRegion.Resize(, 15).Value For I = 2 To UBound(arrTemp, 1) - 1 strKey = "LEFT" & arrTemp(I, 3) If coll_isExists(coll, strKey) Then P = coll(strKey) For J = 5 To 7 arr(P, J - 1) = arr(P, J - 1) + arrTemp(I, J) Next J End If strKey = "RIGHT" & arrTemp(I, 11) If coll_isExists(coll, strKey) Then P = coll(strKey) For J = 13 To 15 arr(P, J - 2) = arr(P, J - 2) + arrTemp(I, J) Next J End If Next I End If End With Application.DisplayAlerts = False .Close SaveChanges:=False Application.DisplayAlerts = True End With v = Dir Wend For Each v In Array(4, 5, 6, 11, 12, 13) For I = 1 To UBound(arr, 1) If arr(I, v) = "" Then arr(I, v) = 0 Next I Next v rngSrc.Value = arr Application.ScreenUpdating = True End Sub Private Function coll_isExists(coll As Collection, strKey As String) As Boolean On Error Resume Next With coll(strKey) If Err.Number = 0 Then coll_isExists = True Else coll_isExists = False End With End Function احفظ المصنف ، ستظهر لك رسالة اختر منها No ثم اختر نوع الحفظ Macro-Enabled Workbook (ليتم حفظ الأكواد) أغلق المصنف ثم افتح المجلد المسمى Sameh ، وقم بحذف المصنف Total والذي امتداد xlsx وأبقي على المصنف الجديد المسمى Total والذي امتداده xlsm الآن افتح المصنف الجديد Total ثم اضغط Alt + F8 ليظهر لك قائمة اختر منها اسم الإجراء الفرعي المطلوب تنفيذه ، ثم انقر Run لتنفيذ الماكرو وراجع النتائج للتأكد من عمل الكود رابط الملف من هنا تقبل تحياتي

عوداً حميداً أخي الكريم رؤوف لقد اشتقنا لرؤية مشاركاتك الموضوع يحتاج لمزيد من التفاصيل وملف مرفق تقبل تحياتي

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

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

سؤال أخير إن شاء الله هل الجداول التي يتم فيها البحث ثابتة أي تبدأ دائماً في نفس عناوين الخلايا؟أم أنها غير ثابتة؟ وهل عدد الجداول المطلوب البحث فيها ثابت أم متغير؟

أخي حسين نعم أفهم المنطق من طلبك ولكن ليس هذا سؤالي .. سؤالي هل بعد كتابة قيمة جديدة مطلوب توزيعها ستتغير آخر قيمة (كما في المثال الرقم 5) أم أن التعامل سيكون مع أول خلية فارغة بصرف النظر عن القيمة 5؟

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

وعليكم السلام أخي الكريم حسين ماذا عن آخر قيمة موجودة في الخلية I11 والتي قيمتها 5 وهو أقل من القيمة المقابلة لها في العمود H والتي قيمتها 28 ؟ أقصد بسؤالي هل عند كتابة رقم جديد مطلوب توزيعه في الخلية J1 ما مصير هذه القيمة 5 ؟ هل سيتم تعديل الخلية أم أن التوزيع سيكون للرقم الجديد مع أول خلية فارغة بصرف النظر عن القيمة 5؟

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