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

أخي الكريم قلم الإكسيل إليك الكود التالي وإن شاء الله يكون حل للمشكلة بشكل قطعي Sub ExtractDuplicatedNumbers() Dim R, C As Integer With CreateObject("Scripting.Dictionary") For Each R In [{35,40}] For C = 8 To 31 If Cells(R, C).Value > 1 Then .Item(Cells(R - 1, C).Value) = "" Next Next [H45].Resize(, .Count).Value = .Keys .RemoveAll End With Call GetCodes End Sub Private Sub GetCodes() Dim C As Integer, VA As Variant Const P = 45 Application.ScreenUpdating = False For C = 8 To Cells(P, 8).End(xlToRight).Column VA = Application.Transpose(Filter(Evaluate("TRANSPOSE(IF(ISNUMBER(MATCH(" & Cells(P, C).Value & "-$E$4:$E$27,$F4:$F$27,0)),$C$4:$C$27))"), False, False)) Cells(P + 1, C).Resize(UBound(VA)).Value = VA Next C Application.ScreenUpdating = True End Sub تقبل تحياتي Extract Duplicates & Items Related YasserKhalil.rar

أعتقد أن اسم الأداة ليس كما ذكرت في مشاركتك إنما تكون بنفس الاسم تقريباً Microsoft Calendar..ابحث عنها وحاول إدراجها

جرب الكود التالي عله يفي بالغرض Fit Screen Resolution On UserForm YasserKhalil.rar

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

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

أخي الكريم محمد يا ريت الاسم بالعربية بالنسبة للأقواس لا توضع بشكل يدوي في بداية أو نهاية المعادلة .. يتم تحرير المعادلة ثم في النهاية يتم الضغط على ثلاثة مفاتيح Ctrl + Shift + Enter معاً قم بتحميل المرفق وشاهد النتائج بنفسك .. هل حملت المرفق أم أنك قمت بتنفيذ المعادلة بشكل مباشر؟

أخي الكريم أبو حمادة حاول تستخدم خاصية البحث في المنتدى ، وإن شاء الله تجد أجوبة لكثير من الأسئلة إليك الكود التالي يوضع في حدث الفورم Private Sub UserForm_Initialize() With Application .WindowState = xlMaximized Zoom = Int(.Width / Me.Width * 80) Width = .Width: Height = .Height Left = 0: Top = 0 End With End Sub ودا ملف مطبق فيه الكود تقبل تحياتي Fit Screen Resolution YasserKhalil.rar

أخي الكريم مختار البركاني السطر الأول هو سطر للإعلان عن المتغيرات المستخدمة في الكود السطر التالي Set MyRange = Range(Cells(8, 1), Cells(Cells(Rows.Count, 1).End(3).Row, 1)) هذا السطر يتم فيه تعيين قيمة للمتغير الذي سنتعامل معه وهو النطاق الذي سنقوم بعمل حلقة تكرارية لخلاياه وهو يبدأ من الخلية في العمود الأول في الصف الثامن وينتهي في نفس العمود في آخر خلية بها بيانات هذا الجزء من الكود For Each Cel In MyRange If Cel.Value = 0 And Cel.Offset(, 4).Value = 0 Then If Not Cel Is Nothing Then If Rng Is Nothing Then Set Rng = Cel Else Set Rng = Union(Rng, Cel) End If Next Cel هنا حلقة تكرارية لكل خلية من خلايا النطاق المذكور في السطر السابق يتم اختبار قيمة الخلية وكذلك قيمة الخلية في العمود الخامس التي تبعد عن الخلية الحالية بمقدار 4 أعمدة في نفس الصف ، فإذا كانت الخليتين قيمتهما = صفر يتم تنفيذ السطر التالي والذي يقوم بتخزين نطاق الخلية الحالية في متغير آخر باسم Rng .. وفي كل حلقة يتم تخزين النطاق الجديد إضافة إلى النطاق القديم .. بمعنى يتم تجميع نطاقات الخلايا التي ينطبق عليها الشرط ثم If Not Rng Is Nothing Then Rng.EntireRow.Hidden = True يتم إخفاء الصفوف للنطاق المسمى Rng (الخلايا التي انطبق عليها الشرط) مرة واحدة وهذا أسرع من الكود الأول الذي يقوم بالتعامل مع صف صف ... الفكرة في السرعة هنا في أداء الكود أن الكود يتعامل مع الخلايا التي ينطبق عليها الشرط مرة واحدة ActiveSheet.PrintPreview أخيراً يتم معاينة أو طباعة ورقة العمل النشطة وفي نهاية المطاف يتم إظهار الصفوف التي تم إخفائها مرة أخرى أرجو أن تكون الصورة قد اتضحت أخي الكريم تقبل تحياتي

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

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

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

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

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

أخي وائل كدا أنا هتوه منك مرة تقولي حسب الشهر .. ودلوقتي تقولي فيه أوراق تانية باسم q1 و q2 .. وفي النهاية غيرت مسارك وقلت خلينا نتعامل مع الورقة النشطة يا ريت تكون دي آخر محاولة مني Sub TransferTables_YasserKhalil() Dim CN, D As Integer, R As Integer, L As Integer, N As Integer Const C = 30 CN = [{1,3,7,28,29,30}] D = Sheets("Data").Cells(Rows.Count, 2).End(3).Row + 1 R = 5 Application.ScreenUpdating = False With ActiveSheet L = .Cells(.Rows.Count, 3).End(xlUp).Row Do With .Cells(R, 4) If .Value > "" Then N = .CurrentRegion.Columns(2).Find("*", , xlValues, , , xlPrevious).Row - R - 3 Sheets("Data").Cells(D, 2).Resize(N + 1, 3).Value = Array(.Cells(1, 10).Value, .Cells(2).Value, .Value) Sheets("Data").Cells(D, 5).Resize(N, 6).Value = Application.Index(.Cells(5, 0).Resize(N, C).Value, Evaluate("ROW(1:" & N & ")"), CN) Sheets("Data").Cells(D + N, 5).Resize(, 6).Value = Application.Index(.Cells(17, 0).Resize(2, C).Value, 1, CN) D = D + N + 1 End If End With R = R + 21 Loop While R < L End With Application.ScreenUpdating = True End Sub ويا رب تظبط معاك عشان أنا بدأت أهيس وشوية ورايح أنااااااااااااااااااااااااااااااااااااااااام تقبل تحياتي

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

يبدو أن هناك مشكلة بالنسبة لهذه الأداة مع الـ 64 بت يمكن استخدام بديل لها قم بالإطلاع على الملف ويمكنك تصدير الأكواد المرتبطة والفورم الخاص بها إلى ملفك Date Calendar In UserForm.rar

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

أخي الكريم وائل إليك الكود ويوضع في موديول عادي (بلاش حدث ورقة العمل) يتم تنفيذ الكود على الشهر الحالي فقط أي أن الورقة المرتبطة بالشهر الحالي فقط هي التي سيتم جلب البيانات منها أرجو أن يكون المطلوب Sub TransferTables_YasserKhalil() Dim CN, D As Integer, R As Integer, L As Integer, N As Integer, strMonth As String Const C = 30 CN = [{1,3,7,28,29,30}] D = Cells(Rows.Count, 2).End(3).Row + 1 R = 5 strMonth = Month(Date) If Evaluate("=ISREF('" & strMonth & "'!A1)") Then Application.ScreenUpdating = False With ThisWorkbook.Worksheets(strMonth) L = .Cells(.Rows.Count, 3).End(xlUp).Row Do With .Cells(R, 4) If .Value > "" Then N = .CurrentRegion.Columns(2).Find("*", , xlValues, , , xlPrevious).Row - R - 3 Cells(D, 2).Resize(N + 1, 3).Value = Array(.Cells(1, 10).Value, .Cells(2).Value, .Value) Cells(D, 5).Resize(N, 6).Value = Application.Index(.Cells(5, 0).Resize(N, C).Value, Evaluate("ROW(1:" & N & ")"), CN) Cells(D + N, 5).Resize(, 6).Value = Application.Index(.Cells(17, 0).Resize(2, C).Value, 1, CN) D = D + N + 1 End If End With R = R + 21 Loop While R < L End With Application.ScreenUpdating = True Else MsgBox "There Is No Such Sheet", 64: Exit Sub End If End Sub تقبل تحياتي

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

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

أخي الكريم خالد إليك الملف المرفق عله يفي بالغرض .. الإدخالات المسموح بها هي ما بين الصفر والحد الأقصى لكل مادة وحرف الغين فقط (لغياب الطلاب) Restrict Entries In TextBoxes.rar

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

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

أخي الكريم وائل مش فاهم يعني ايه هتشتغل بالكودين ... ألم يؤدي الكود المرفق في المشاركة السابقة الغرض ؟أم أن هناك إضافات أخرى مطلوبة على الكود

جرب معادلة الصفيف التالية =INDEX(Table1[السعر],MATCH(MAX((Table1[الصنف]=K12)*(Table1[الحركه]="مشتريات")*(Table1[التاريخ])),Table1[التاريخ],FALSE),1) لا تنسى أن تضغط على Ctrl + Shift + Enter تقبل تحياتي