الحسامي

السلام عليكم بالنسبة لاكواد الحفظ هنا يمكننا تعطيل الحفظ باسم وتفعيل الحفظ العادي Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If SaveAsUI = True Then Cancel = True End Sub وهنا بالعكس يمكننا تعطيل الحفظ العادي وتفعيل الحفظ باسم Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Cancel = True If SaveAsUI = True Then Cancel = False End Sub

السلام عليكم اخي الكريم هنا المرفق المطلوب وبالنسبة لطلبك الاخر فلم يتم استيعابه بالصورة المطلوبة و (ساحاول ) على قدر فهمي للامر وعلى قدر وجود الوقت لذلك المبيعات.rar

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

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

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

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

السلام عليكم بارك الله فيكم اخي ابو حسين واخي ابو عبدالله واخي ابو عمر ولتعدد الحلول ونفس مبدأ كود اخي ابو عبدالله يمكن استخدام الكود التالي حسبي فهمي للموضوع If Not Intersect(Target, [B2:d4]) Is Nothing Then [c8] = _ (Target + Cells(Target.Row, "e")) - (Target * Cells(Target.Row, "f")) مزدوج.rar

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

السلام عليكم ما شاء الله عليك اخي طارق عمل اكثر من رائع وكما قال اخي ياسر من باب تنوع الحلول هنا حل اخر وبارك الله فيك اخي ياسر وتحياتي لاستاذنا خبور Invoice4.rar

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

ما شاء الله اخي خبور عمل اكثر من رائع بارك الله فيك

السلام عليكم اخي الكريم .... لا يوجد شئ اسمه شرح كود و لو تم الطلب بجزئية معينة لم تفهمها لكان الامر ابسط اما شرح كود كامل فمن الصعوبة بمكان لذلك فهو بالاساس يشتمل على اساسيات الاكواد من قاعدة IF وجمل التكرار و استخدام ال Range واخفاء الاعمدة وعلى اية حال ساقوم بشرح ما يتيسر لي ---------------------------------------- الكود يعمل بناءا على ثلاثة احتمال الحالة الاولى اذا كانت قيمة القائمة تساوي 33 فيقوم باضهار كافة الاعمدة الحالة الثانية اذا كانت قيمة القائمة تساوي 32 فيقوم باضهار اعمدة معينة k .. s .. aa الخ وهذه الاعمدة ترقيمها 11 ... 19 ... 27 ولغاية السطر 251 الذي يمثل السكر IQ اي ان هذه الارقام متوالية هندسية تبدأ من الرقم 11 وتزداد بالرقم 8 في كل مرة حتى الوصول للرقم 251 ... ولذلك تم استخدام For i = 11 To 251 Step 8 اما الحالة الثالثة اذا كانت قيمة القائمة من 1 - 31 اي ايام الشهر بالاضافة الى اجمالي الشهر والمطلوب اضهار الاعمدة التي تخص كل بند ويتم تحديد الاعمدة المراد اظهارها بناءا على قيمة القائمة وبناءاً على معادلات رياضية للتوضيح : قيم القائمة الموجودة ............. 1 2 3 4 .... 31 بداية الاعمدة المطلوب اضهارها 4 12 20 28 .... 244 ورياضيا يتم ربطها بالصيغة ص=((س-1)*5)+(س*3)+1 بحيث لو كانت قيمة س = 1 اذن ص=((1-1)*5)+(1*3)+1 ... ص=4 بحيث لو كانت قيمة س = 2اذن ص=((2-1)*5)+(2*3)+1 ... ص=12 ... وهكذا وتم تحديد باية العمود ونهاية العمود المراد اضهاره Range(Cells(1, ((x1 - 1) * 5) + x1 * 3 + 1), _ Cells(1, ((x1 - 1) * 5) + x1 * 3 + 1 + 7)).EntireColumn.Hidden = False وتم اضافة الرقم 7 لتحديد اخر عمود في الاعمدة المطلوبة لان المطلوب اضهار 8 اعمدة وبزيادة 7 على العمود الاول يصبح لدينا الاعمدة ال8 المطلوبة

السلام عليكم اخي معتصم بارك الله فيك على المجهود الذي تقوم به وقاعدة عامة : الملفات الموجودة في المنتدى تنتقل ملكيتها للجميع بمجرد وضعها من صاحبها فاعمل بها ما تشاء وبل على العكس يفرحنا اي عمل يستفيد به الاخرين وهذا اساس وجودنا في المنتدى واخى ياسر بارك الله فيك ويمكنك الانابة عني وعن الجميع كما تشاء في سبيل نشر العلم

السلام عليكم والله يا ابو احمد انك رائع جدا جدا مجهود ونشاط وافكار واعمال تحسد عليها بارك الله فيك واتمنى لك التقدم والنجاح

السلام عليكم اخي الكريم وبعد اذن اخي وحبيبي ابو احمد لا يوجد داعي لهذا الكود الضخم والمعقد بعض الشئ والذي يصعب تتبعه ويمكنك الاستغناء عته وقد قمت بعمل كود مختصر يلبي طلبك Dim x1, i As Integer Application.ScreenUpdating = False ActiveSheet.Unprotect Password:="haitham29181" Columns("d:iq").EntireColumn.Hidden = True If ActiveSheet.Shapes("Drop Down 283").ControlFormat.Value = 33 Then Columns("d:iq").EntireColumn.Hidden = False Range("d6").Select ElseIf ActiveSheet.Shapes("Drop Down 283").ControlFormat.Value = 32 Then For i = 11 To 251 Step 8 Cells(1, i).EntireColumn.Hidden = False Next Range("k6").Select Else x1 = ActiveSheet.Shapes("Drop Down 283").ControlFormat.Value Range(Cells(1, ((x1 - 1) * 5) + x1 * 3 + 1), _ Cells(1, ((x1 - 1) * 5) + x1 * 3 + 8)).EntireColumn.Hidden = False Cells(6, ((x1 - 1) * 5) + x1 * 3 + 1).Select End If ActiveSheet.Protect Password:="haitham29181" وبالنسبة لحماية الخلايا فقط قم بغلق الخلايا التي تحتوي على معادلات من خلال كليك يمين format cells ومن ثم protection ثم قم بتفعيل خاصية louck وقد قمت بعمل الخلايا لتاريخ 1/8 كعينة ويمكنك اجراء الباقي على باقي الخلايا مبيعات فرع -1.rar

السلام عليكم هنا اخي التعديل وقد قمت بارفاق ملفين الاول في حالة كانت الخلية"f1" معادلة والملف الثاني بمجرد التعديل بالخلية "f1" مباشرة ----------------------- شكرا اخي كيماس للملاحظة وبارك الله فيك مع الشكر كذلك لاخي ابو احمد وشكرا اخي محمد على مرورك التسلسل22.rar التسلسل33.rar

السلام عليكم اخي الكريم هنا محاولة اخرى مع الشكر لاخي كيماس If [f1].Value <> 0 Then If [a3] <> 0 Then x = [a3] + 19 If Application.WorksheetFunction.CountIf([a3:a22], [f1]) = 1 Then x = 0 [a3:a22] = Empty For i = 1 To 20 Cells(i + 2, 1) = x + i If x + i >= [f1] Then Exit Sub Next i Else [a3:a22] = Empty End If التسلسل11.rar

السلام عليكم بالنسبة لحذف الصف فهو كان ما طلب انا فهمت من الطلب بانك هكذا تريد واتوقع جميع الاخوة هكذا فهموا اذا لم يكن المطلوب مسح البيانات فقد امسح هذا السطر Sheet1.Range(Sheet1.Cells(c.Row, "b"), Sheet1.Cells(c.Row, "ag")) = Empty Dim c As Range For Each c In Sheet1.Range("case") If c.Value = "منقول" Then lstrow = Sheet4.Range("b20000").End(xlUp).Row + 1 Sheet4.Range(Sheet4.Cells(lstrow, "b"), Sheet4.Cells(lstrow, "ag")) = _ Sheet1.Range(Sheet1.Cells(c.Row, "b"), Sheet1.Cells(c.Row, "ag")).Value End If Next c

السلام عليكم اخي ياسر افعل ما يحلو لك للفائدة ومجهود تشكر عليه وبارك الله فيك اخي كيماس كود ممتاز ورائع

السلام عليكم مدى الكود( عموديا) هنا متغير اي مهما كانت طول القائمة سيتم حسابها فقد تم استخدام نطاق مرن اسميناه "case" اما مدى الكود بشكل افقي فيقوم باخذ البيانات ابتداءاً من الخلية الثانية بدون المتسلسل ولو اردنا الترحيل بدون المسلسل فقط امسح السطر Sheet4.Cells(lstrow, "a") = Z: وهنا سيقوم بالترحيل بدون المسلسل والكود مكون من جمل تكرار مع استخدام اداة الشرط "If" واستخدام تعاريف الخلايا فقط وهنا الكود بشكله النهائي Dim c As Range For Each c In Sheet1.Range("case") If c.Value = "منقول" Then lstrow = Sheet4.Range("b20000").End(xlUp).Row + 1 Sheet4.Range(Sheet4.Cells(lstrow, "b"), Sheet4.Cells(lstrow, "ag")) = _ Sheet1.Range(Sheet1.Cells(c.Row, "b"), Sheet1.Cells(c.Row, "ag")).Value Sheet1.Range(Sheet1.Cells(c.Row, "b"), Sheet1.Cells(c.Row, "ag")) = Empty End If Next c

السلام عليكم رائع اخي معتصم شرح اكثر من رائع اتمنى لك التقدم والنجاح تحياتي

السلام عليكم بارك الله فيكم اخوتي في الله احببت ان اشارك معكم في هذا الموضوع ( من باب المشاركة والتنوع ) Dim c As Range For Each c In Sheet1.Range("case") If c.Value = "منقول" Then Z = Z + 1 lstrow = Sheet4.Range("b20000").End(xlUp).Row + 1 Sheet4.Range(Sheet4.Cells(lstrow, "b"), Sheet4.Cells(lstrow, "ag")) = _ Sheet1.Range(Sheet1.Cells(c.Row, "b"), Sheet1.Cells(c.Row, "ag")).Value Sheet1.Range(Sheet1.Cells(c.Row, "b"), Sheet1.Cells(c.Row, "ag")) = Empty Sheet4.Cells(lstrow, "a") = Z: End If Next c المنقول.rar

السلام عليكم اخي باسم هناك سطر زائد في الكود وهو ListBox1.List(V, 3) = q.Address ------------------------ اضافة اخرى يمكنك عدم التكرار في الكود واستخدم جمل التكرار اي الاسطر التالية ListBox1.List(V, 0) = q.Offset(0, -1).Value ListBox1.List(V, 1) = q.Offset(0, 0).Value ListBox1.List(V, 2) = q.Offset(0, 1).Value ListBox1.List(V, 3) = q.Offset(0, 2).Value ListBox1.List(V, 4) = q.Offset(0, 3).Value ListBox1.List(V, 5) = q.Offset(0, 4).Value ListBox1.List(V, 6) = q.Offset(0, 5).Value ListBox1.List(V, 7) = q.Offset(0, 6).Value ListBox1.List(V, 8) = q.Offset(0, 7).Value ListBox1.List(V, 9) = q.Offset(0, 8).Value ListBox1.List(V, 10) = q.Offset(0, 9).Value ListBox1.List(V, 11) = q.Offset(0, 10).Value ListBox1.List(V, 12) = q.Offset(0, 11).Value ListBox1.List(V, 13) = q.Offset(0, 12).Value ListBox1.List(V, 14) = q.Offset(0, 13).Value ListBox1.List(V, 15) = q.Offset(0, 14).Value يمكنك كتابتها بصورة اخرة كالتالي For I = 0 To 15 ListBox1.List(V, I) = q.Offset(0, I - 1).Value Next 22.rar

السلام عليكم تحية كلها تقدير ... تخص الصاحب الغالي ... و عفواً لا حصل تقصير ... بقدرك يا بعد حالي ... بارك الله فيك اخي خبور اخي عادل ما شاء الله عليك تحياتي واشواقي

السلام عليكم مجهوج جبار تستحق عليه الشكر والثناء اتمنى لك التوفيق والتقدم بارك الله فيك تحياتي