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

الأخ الكريم الوليد زين العابدين إليك الكود التالي عله يفي بالغرض Sub CutRow() Dim WS As Worksheet, SH As Worksheet, LR As Long, I As Long Dim Cell As Range Set WS = Sheets(" الخطة النظريةو التنفيذ الفعلي"): Set SH = Sheets("البنود المنتهية") Application.ScreenUpdating = False For Each Cell In WS.Range("N5:N" & WS.Cells(Rows.Count, 1).End(xlUp).Row) If Cell.Value >= 1 Then LR = IIf(SH.Cells(Rows.Count, 1).End(xlUp).Row <= 4, 4, SH.Cells(Rows.Count, 1).End(xlUp).Row + 1) Cell.EntireRow.Copy SH.Range("A" & LR) End If Next Cell For I = WS.Cells(Rows.Count, 1).End(xlUp).Row To 5 Step -1 If Cells(I, "N").Value >= 1 Then Cells(I, "N").EntireRow.Delete End If Next I Application.CutCopyMode = False Application.ScreenUpdating = True End Sub لا تنسى أن تحدد أفضل إجابة كما لا تنسى أن تضغط أعجبني هذا إذا أعجبك الحل وأدى الغرض تقبل تحياتي Cut Cell Entire Row To Another Sheet.rar

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

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

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

لم تنوه في المشاركة الأولى عن ذلك الأمر ولذا أنا دائماً أؤكد على التوضيح التام للطلب حتى لا يطول الموضوع بدون داعي إليك الكود التالي جربه مع ملفك الأصلي وشوف النتائج صحيحة أم لا ... إذا كان هناك أوراق عمل أخرى غير 120 وجب التعديل في الكود في السطر التالي If WS.Name <> "Final" Then ستضيف أسماء أوراق العمل المراد استثناءها من تنفيذ الكود ... Sub UniqueListFromMultipleSheets() Dim X, Y(), I&, J&, K&, WS As Worksheet ReDim Y(1 To Rows.Count, 1 To 2) With CreateObject("Scripting.Dictionary") .CompareMode = 1 For Each WS In ThisWorkbook.Worksheets If WS.Name <> "Final" Then X = WS.Range("D10:G" & WS.Cells(Rows.Count, 4).End(xlUp).Row).Value For I = 2 To UBound(X) If Len(X(I, 1)) Then If .Exists(X(I, 1)) Then K = .Item(X(I, 1)) Y(K, 2) = Y(K, 2) + X(I, 4) Else J = J + 1 .Item(X(I, 1)) = J Y(J, 1) = X(I, 1) Y(J, 2) = X(I, 4) End If End If Next I End If Next WS End With With Sheets("Final") .UsedRange.ClearContents .Range("A1:B1") = Array("اسم الصنف", "الموجود من واقع الجرد") .Range("A2").Resize(J, 2).Value = Y() End With End Sub لا تنسى أن تنهي الموضوع بتحديد أفضل إجابة ليظهر الموضوع مجاب ومنتهي تقبل تحياتي

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

أخي الكريم بالنسبة للخطأ في المعادلة في الخلية L6 قم باستخدام المعادلة بالشكل التالي =IFERROR(IF(DAY(K6)>=DAY(J6),DAY(K6)-DAY(J6),DAY(K6)+DAY(EOMONTH(K6,-1))-DAY(J6)),"") بالنسبة لطلبك الأول يرجى وضع بعض البيانات الوهمية في كذا صف للعمل عليه .. وإرفاق شكل النتائج المتوقعة في ورقة العمل المسماة "البنود المنتهية"

جرب الملف المرفق Mostafa.rar

أخي الكريم أبو إسلام أهلاً ومرحباً بك في المنتدى ونورت بين إخوانك يرجى الإطلاع على رابط التوجيهات في الموضوعات المثبتة في المنتدى لمعرفة كيفية التعامل مع المنتدى كما يرجى تغيير اسم الظهور للغة العربية لسهولة التواصل إليك الكود التالي لعله يفي بالغرض Sub UniqueListFromMultipleSheets() Dim X, Y(), I&, J&, K&, WS As Worksheet ReDim Y(1 To Rows.Count, 1 To 2) With CreateObject("Scripting.Dictionary") .CompareMode = 1 For Each WS In ThisWorkbook.Worksheets(Array("1", "2", "3")) X = WS.Range("D10:G" & WS.Cells(Rows.Count, 4).End(xlUp).Row).Value For I = 2 To UBound(X) If Len(X(I, 1)) Then If .Exists(X(I, 1)) Then K = .Item(X(I, 1)) Y(K, 2) = Y(K, 2) + X(I, 4) Else J = J + 1 .Item(X(I, 1)) = J Y(J, 1) = X(I, 1) Y(J, 2) = X(I, 4) End If End If Next I Next WS End With With Sheets("Final") .UsedRange.ClearContents .Range("A1:B1") = Array("اسم الصنف", "الموجود من واقع الجرد") .Range("A2").Resize(J, 2).Value = Y() End With End Sub لا تنسى أن تحدد أفضل إجابة ليظهر الموضوع مجاب ومنتهي كما لا تنسى أن تضغط على كلمة "أعجبني هذا" في حال أعجبك الحل المقدم وأدى الغرض تقبل تحياتي Extract Unique Values From Multiple Sheets YasserKhalil.rar

أخي الكريم أعتقد أن المعادلة تعمل على 2003 ..ممكت ترفق شكل النتيجة للمعادلة بعد إدخالها .. ايه اللي بيظهر معاك هل جربت تستبدل الفاصلة الموجودة في المعادلة بفاصلة منقوطة , ;

أخي الكريم اضغط ملفك ثم قم بإرفاقه مع توضيح بعض النتائج المتوقعة إذا أمكن

أخي الكريم الدهشوري إليك الملف التالي عله يفي بالغرض قمت باستخراج البيانات المطلوبة باستخدام دالة معرفة ... بالنسبة لطلبك الثاني الترتيب .. يرجى توضيح ما هي آليات الترتيب .. هل الترتيب سيكون للنوع ثم السن أم للأسماء ثم السن أم .... حدد آليات الترتيب المطلوبة Extract Birth Dates Gender UDF Function.rar

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

شااااااااايف السطر ده ThisWorkbook.Application.Quit غيره للسطر ده وجرب وقولي ThisWorkbook.Close

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

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

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

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

الأخ الكريم أسامة هل أرفقت بعض النتائج المتوقعة ؟؟ لمعاملة أو اثنتين؟

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

أخي الفاضل أبو نبأ إليك الكود التالي عله يكون المطلوب .. حاولت الابتعاد عن استخدام الحلقات التكرارية حتى يعمل الكود بكفاءة مع البيانات الكثيرة اعتمدت في التفكير على استخدام الفلترة ... أي كل رقم كود أقوم بفلترته ثم نسخ البيانات المرتبطة بعملية الفلترة إلى آخر ورقة عمل أرجو أن يكون المطلوب Sub TransferDataBasedOnCode() Dim wsMain As Worksheet, wsBranch As Worksheet, SH As Worksheet Dim rngData As Range, Rng As Range, Cell As Range, LR As Long Set wsMain = Sheets("الرئيسية"): Set wsBranch = Sheets("الفرعية"): Set SH = Sheets("الكود الموجود") LR = IIf(wsBranch.Cells(Rows.Count, 1).End(xlUp).Row = 1, 2, wsBranch.Cells(Rows.Count, 1).End(xlUp).Row) Set Rng = wsBranch.Range("A2:A" & LR) Set rngData = wsMain.Range("A1:K" & wsMain.Cells(Rows.Count, 1).End(xlUp).Row) Application.ScreenUpdating = False If Application.WorksheetFunction.CountA(Rng) < 1 Then MsgBox "لا يوجد أرقام كود لترحيلها", vbInformation: Exit Sub For Each Cell In Rng With wsMain .AutoFilterMode = False .Range("A1:K1").AutoFilter Field:=2, Criteria1:=Cell.Value If rngData.Columns(1).SpecialCells(xlCellTypeVisible).Count = 1 Then GoTo Skipper rngData.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy SH.Range("A" & SH.Cells(Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial xlPasteValues End With Skipper: Next Cell wsMain.AutoFilterMode = False SH.Range("A1").Select Application.CutCopyMode = False Application.ScreenUpdating = True End Sub لا تنسى أن تحدد أفضل إجابة ولو فيها تعب ليك اضغط على "أعجبني هذا" إذا أعجبك الحل تقبل تحياتي :fff: Transfer Data Based On Code.rar

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

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

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

لمزيد من التفاصيل حول كيفية التعامل مع المنتدى يرجى زيارة ها الرابط من هنا