محمد حجازي

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

السلام عليكم ... هذا يعتمد على ترتيب البيانات في الخلية التي تريد فصلها ، وتستطيع عمل ذلك عن طريق التعليمة MID و التي تحتوي على ثلاثة وسائط : الأول : لسلسلة البيانات. الثاني : لرقم الحرف الذي سيتم الاقتطاع بدءاً منه. الثالث : لعدد الأحرف المقتطعة. مرفق مثال يوضح الصورة: MID.zip

السلام عليكم ... جرب التعديل التالي: Sub MySort() Dim MyValue As Double Dim i As Long MyCondition = Array("1 F", "3 F", "1 FG", "3 FG", "1-2F", "2-1F", "3-4F", "4-3F", "1-2FG", "2-1FG", "3-4FG", "4-3FG", "1 FDA", "1-2FDA", "2-1FDA", "1 FGC", "3 FGC", "1 FGH", "3 FGH") Worksheets("Master").Range("FD10:FD22").ClearContents Worksheets("Master").Range("FE10:FE22").ClearContents For Each MyCell In Worksheets("Master").Range("V10:V22").Cells For i = 0 To UBound(MyCondition) If MyCell.Value = MyCondition(i) Then Worksheets("Master").Cells(MyCell.Row, 160).Value = Worksheets("Master").Cells(MyCell.Row, 8).Value Worksheets("Master").Cells(MyCell.Row, 161).Value = Worksheets("Master").Cells(MyCell.Row, 9).Value GoTo RYes End If Next i RYes: Next MyCell Worksheets("Master").Range("J10:J22").Value = Worksheets("Master").Range("H10:H22").Value Worksheets("Master").Range("K10:K22").Value = Worksheets("Master").Range("I10:I22").Value Do MyValue = Application.WorksheetFunction.Min(Worksheets("Master").Range("FD10:FD22")) - 6 For Each MyCell In Worksheets("Master").Range("J10:J22").Cells If Not MyCell.Value = "" And Not Worksheets("Master").Cells(MyCell.Row, 160) = "" Then If MyCell.Value - MyValue <= 10 Then Worksheets("Master").Cells(MyCell.Row, 10) = MyValue Worksheets("Master").Cells(MyCell.Row, 160).ClearContents Else Worksheets("Master").Cells(MyCell.Row, 160) = MyCell.Value End If End If Next MyCell Loop Until Application.WorksheetFunction.Count(Worksheets("Master").Range("FD10:FD22")) < 1 Do MyValue = Application.WorksheetFunction.Min(Worksheets("Master").Range("FE10:FE22")) - 6 For Each MyCell In Worksheets("Master").Range("K10:K22").Cells If Not MyCell.Value = "" And Not Worksheets("Master").Cells(MyCell.Row, 161) = "" Then If MyCell.Value - MyValue <= 10 Then Worksheets("Master").Cells(MyCell.Row, 11) = MyValue Worksheets("Master").Cells(MyCell.Row, 161).ClearContents Else Worksheets("Master").Cells(MyCell.Row, 161) = MyCell.Value End If End If Next MyCell Loop Until Application.WorksheetFunction.Count(Worksheets("Master").Range("FE10:FE22")) < 1 Worksheets("Master").Range("B10:CF22").Sort Key1:=Worksheets("Master").Range("K10"), Order1:=xlAscending, Header:=xlGuess End Sub ولكن يجب الانتباه إلى أن الفرز في نهاية الحل يتم على أساس العامود K وذلك للمجال B10:CF22 ، للعلم فقط.

السلام عليكم ... كليك يمين ومن ثم اضغط على الخيار Table Options ، وتحت Format Options حدد المربع Preserve formatting واضغط على OK.

السلام عليكم ... يمكنك استخدام حقيبة الملفات لإنشاء نسخة احتياطية أو عن طريق كود يحفظ المصنف في ملف احتياطي كلما أردت إغلاق الملف ، وذلك كما يلي : اضغط على Alt+F11 لتظهر لك نافذة ، ادخل على ThisWorkbook وقم باخيار الحدث BeforeClose حتى يندرج لك الإجراء التالي: Private Sub Workbook_BeforeClose(Cancel As Boolean) End Sub الآن ضع داخل الإجراء السابق الكود الذي تريده ، وذلك طبعاً بعد قراء الموضوع الموجود في الرابط التالي: http://www.officena.net/ib/index.php?showtopic=5852

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

السلام عليكم ... يبدو أنني فهمت مشكلتك بشكل خاطئ. على العموم هناك وظيفة إضافية خاصة بذلك: من القائمة Tools اختار Add-Ins لتظهر لك نافذة. إذا لم يكن مربع الاختيار Analysis ToolPak مفعلاً فقم بتفعيله ثم اضغط OK . قم باختيار القائمة Tools مرة أخرى وستجد الخيار Data Analysis قد أدرج ضمنها. الآن قم بالضغط على الخيار Data Analysis لتظهر لك نافذة ، اختر منها Histogram ليظهر لك معالج خاص بتحويل البيانات الإحصائية من مفردات إلى فئات.

السلام عليكم ... أهلاً وسهلاً بك عضواً فعالاً في المنتدى :d

السلام عليكم ... ضع الكود التالي في الورقة المطلوب تطبيق الكود عليها (الورقة التي تريد نقل بيانات الورقة الأولى إليها): Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo NoNumber If Target.Column = 1 And Target.Row >= 2 And Target.Row <= 20 Then If Target.Value = "" Then Exit Sub Me.Cells(Target.Row, 2).Value = Application.WorksheetFunction.VLookup(Target.Value, Sheets(1).Range("A2:B20").Value, 2, False) End If Exit Sub NoNumber: If Err = 1004 Then MsgBox "الرقم المدخل غير موجود" Target.ClearContents End If End Sub بالتوفيق

السلام عليكم... تابع الرابط التالي: http://www.officena.net/ib/index.php?showtopic=530 وبالنسبة لتعبئة نطاق معين بهذه الأرقام ، فقط يلزمني معرفة النطاق بالتحديد لأكتب لك الكود. بالتوفيق

السلام عليكم ... طيب يا أخي ، حدد احتمالات المباراة: مثلاً عند التعادل إيش يصير؟ ، يعني مفكر الناس كلها بتابع الكرة. :d

السلام عليكم ... جرب التعليمة ADDRESS مع التعليمة INDIRECT : =INDIRECT(ADDRESS(A1;B1)) الصيغة السابقة تقوم بإرجاع قيمة الخلية المحدد برقم السطر الموجود في الخلية A1 ورقم العامود الموجود في الخلية B1 . بالتوفيق

السلام عليكم ... جرب التعديل التالي: Book11111.zip

السلام عليكم ... الأسلوب السابق يعتمد على الأعمدة F ، G ، H المخفية وسوف أشرح إن شاء الله الصيغ الموجودة في هذه الأعمدة بصورة متسلسلة وذلك حتى نصل للحل ، وسوف أعتمد على شرح الصيغ الموجودة في ورقة الراسبين بصورة تمكنك من فهم الصيغ الموجودة في ورقة الناجحين (لأن الاختلاف بين الطريقتين بسيط جداً). لنبدأ بسم الله : الخلية F2 في ورقة الراسبين تحتوي على الصيغة التالية: =IF(OR('بيانات الطلاب'!B2>=D$3;'بيانات الطلاب'!B2="");"";'بيانات الطلاب'!A2) الصيغة السابقة تقوم بفرز الطلاب الراسبين لنقوم بالتعامل معهم لاحقاً ، و الصيغة تعتمد على الدالة IF و المعامل المنطقي OR و تفسير الصيغة هو كالتالي: إذا كانت الخلية B2 من الورقة "بيانات الطلاب" (الخلية المقابلة للخلية F2 في العامود B الموجود في الورقة "بيانات الطلاب") تحتوي على قيمة أكبر أو تساوي درجة النجاح D$3 (طالب ناجح) أو لا تحتوي على أية بيانات فأبقي على هذه الخلية F2 فارغة (تجاهل هذا الطالب) و إلا فأدرج قيمة الخلية A2 الموجود في ورقة "بيانات الطلاب" في هذه الخلية F2 (أدرج اسم الطالب الراسب). لاحظ أن المراجع الموجودة في الصيغة كلها مراجع نسبية ما عدا المرجع D$3 فهو مرجع مطلق وذلك لأن موضعه ثابت ولا نريد تغيير موضعه عند تعبئة الخلايا. ونلاحظ أيضاً أنه عند الإشارة للمراجع الموجودة في ورقة العمل الحالية"الطلاب الراسبين" فإننا لا نحتاج لكتابة اسم هذه الورقة قبل نطاق الخلايا ، ولكننا نكون مضطرين لكتابة اسم ورقة العمل عندما نريد الإشارة لنطاق موجود في ورقة أخرى. وبنظرة بسيطة نلاحظ أن الصيغة التالية : =IF(OR('بيانات الطلاب'!B2<D$3;'بيانات الطلاب'!B2="");"";'بيانات الطلاب'!A2) و الموجودة في الورقة "الطلاب الناجحين" تختلف عن الصيغة الموجودة في ورقة "الطلاب الراسبين" بشرط الفرز فقط. الخلية G2 في ورقة الراسبين تحتوي على الصيغة التالية: =IF(OR('بيانات الطلاب'!B2>=D$3;'بيانات الطلاب'!B2="");"";'بيانات الطلاب'!B2) نلاحظ أن هذه الصيغة تشبه إلى حد كبير الصيغة الموجودة في الخلية F2 مع فرق بسيط هو أن هذه الصيغة تقوم بإرجاع علامة الطالب بدلاً من اسمه. الخلية H2 في ورقة الراسبين تحتوي على الصيغة التالية: =IF(G2="";"";COUNT(G$2:G2)) الصيغة السابقة كما نلاحظ بسيطة وتعمل على احتساب ترتيب الطالب الناجح (عدد الطلاب الراسبين الموجودين قبل هذا الطالب بما فيهم هذا الطالب). الخلية A2 في ورقة الراسبين تحتوي على الصيغة التالية: =IF(ROW()-1>MAX(H$2:H$50);"";LOOKUP(ROW()-1;H$2:H$50;F$2:F$50)) هنا نحن استفدنا من رقم السطر الحالي في وضع ترتيب للطلاب ، وبما أننا نبدأ من الخلية A2 فنقوم بطرح الرقم 1 من رقم السطر وذلك حتى نستطيع بدء الترتيب من 1 , 2 ,3 , 000 , الخ. الصيغة السابقة تقوم بمقارنة أكبر قيمة من المجال H$2:H$50 مع الترتيب الحالي فإذا كان الترتيب الحالي أكبر من أكبر قيمة موجودة في هذا المجال فهذا يعني أن الطلاب الراسبين قد انتهوا وبذلك تقوم الصيغة بالإبقاء على هذه الخلية فارغة وإلا (أي مازال هناك طلاب راسبون) فتقوم هذه الصيغة بإرجاع اسم الطالب من المجال F$2:F$50 و المقابل لترتيب الطالب الحالي و المأخوذ من المجال H$2:H$50. الخلية B2 في ورقة الراسبين تحتوي على الصيغة التالية: نلاحظ أن هذه الصيغة تشبه إلى حد كبير الصيغة الموجودة في الخلية A2 مع فرق بسيط هو أن هذه الصيغة تقوم بإرجاع علامة الطالب بدلاً من اسمه. والآن نقوم بتعبئة الصيغ الثلاث السابقة على جميع الخلايا الموجودة في نفس الأعمدة وذلك حتى السطر 50 (آخر سطر في جدول الطلاب). أرجو أن أكون قد وفقت في الشرح . بالتوفيق

السلام عليكم ... كليك يمين على الخلية التي تريد إدراج الإرتباط بها ومن ثم تختار ارتباط تشعبي ، ومن ثم ضع مسار الملف الذي تريد فتحه وانقر على موافق. مرفق مثال: بالتوفيق Officena.zip

السلام عليكم ... جرب الكود التالي: Sub MySort() Dim MyValue As Double Worksheets("Master").Range("Q10:Q22").Value = Worksheets("Master").Range("H10:H22").Value Do MyValue = Application.WorksheetFunction.Min(Worksheets("Master").Range("Q10:Q22")) - 6 For Each MyCell In Worksheets("Master").Range("H10:H22").Cells If Not MyCell.Value = "" And Not Worksheets("Master").Cells(MyCell.Row, 17) = "" Then If MyCell.Value - MyValue <= 10 Then MyCell.Value = MyValue Worksheets("Master").Cells(MyCell.Row, 17).ClearContents Else Worksheets("Master").Cells(MyCell.Row, 17) = MyCell.Value End If End If Next MyCell Loop Until Application.WorksheetFunction.Count(Worksheets("Master").Range("Q10:Q22")) < 1 Worksheets("Master").Range("Q10:Q22").Value = Worksheets("Master").Range("I10:I22").Value Do MyValue = Application.WorksheetFunction.Min(Worksheets("Master").Range("Q10:Q22")) - 6 For Each MyCell In Worksheets("Master").Range("I10:I22").Cells If Not MyCell.Value = "" And Not Worksheets("Master").Cells(MyCell.Row, 17) = "" Then If MyCell.Value - MyValue <= 10 Then MyCell.Value = MyValue Worksheets("Master").Cells(MyCell.Row, 17).ClearContents Else Worksheets("Master").Cells(MyCell.Row, 17) = MyCell.Value End If End If Next MyCell Loop Until Application.WorksheetFunction.Count(Worksheets("Master").Range("Q10:Q22")) < 1 Worksheets("Master").Range("B10:O22").Sort Key1:=Worksheets("Master").Range("H10"), Order1:=xlAscending, Header:=xlGuess End Sub الكود السابق يحتاج للعامود Q لتخزين بعض القيم ، ويمكنك إخفاء هذا العامود كما هو موضح في الملف المرفق. تحياتي ProE_Door_Schedule.zip

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

السلام عليكم ... أعتقد أن هذه الميزة موجودة فقط في الإصدار 2003 و الله أعلم

السلام عليكم ... أنا أعرف حق المعرفة بأن أسلوب إعطاء الحلول الجاهزة هو أسلوب عقيم ولا يفيد المتلقين بصورة فعالة ، و كان من الأجدر بي شرح كل كود أقوم بكتابته :) ، ولكن المشاغل لا تترك لي وقتاً ألتقط به أنفاسي ، و وعد مني لأعضاء هذا المنتدى الكرام بتغيير أسلوب تعاملي مع الأسئلة في المستقبل (قدر المستطاع). الآن سوف أشرح الكود وأتحدث في الوقت نفسه عن التغييرات التي يريدها الأخ لورد في كود المرفق. الكود هو التالي: Sub MySort() Dim EndRow As Long Dim MyPath As String Dim NumberSheets() As Integer Dim i As Integer Application.ScreenUpdating = False Set NewBook = Workbooks.Add With NewBook.Sheets(1) .Name = "أوائل الصفوف" .Cells(1, 1).Value = "اسم الطالب" .Cells(1, 2).Value = "الفصل" .Cells(1, 3).Value = "مجموع العلامات" End With For Each MySheet In Workbooks("الصف الأول الإعدادي").Worksheets For Each MyCell In MySheet.Range("I5:I24").Cells If MySheet.Cells(MyCell.Row, 10).Value = "ناجح" Then If MyCell.Value = MySheet.Cells(5, 12).Value Or MyCell.Value = MySheet.Cells(6, 12).Value Or MyCell.Value = MySheet.Cells(7, 12).Value Or MyCell.Value = MySheet.Cells(8, 12).Value Or MyCell.Value = MySheet.Cells(9, 12).Value Then EndRow = NewBook.Sheets(1).Range("A1").CurrentRegion.Rows.Count NewBook.Sheets(1).Cells(EndRow + 1, 1).Value = MySheet.Cells(MyCell.Row, 2).Value NewBook.Sheets(1).Cells(EndRow + 1, 2).Value = MySheet.Name NewBook.Sheets(1).Cells(EndRow + 1, 3).Value = MyCell.Value End If End If Next MyCell Next MySheet With NewBook.Sheets(1).Range(Cells(1, 1), Cells(EndRow + 1, 3)) .Sort Key1:=NewBook.Sheets(1).Range("C2"), Order1:=xlDescending .Borders().LineStyle = xlContinuous .Borders().Weight = xlThin .Borders().ColorIndex = xlAutomatic .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .EntireColumn.AutoFit .Interior.ColorIndex = 34 End With MyPath = Workbooks("الصف الأول الإعدادي").Path & "\أوائل الصفوف" ReDim NumberSheets(2 To NewBook.Worksheets.Count) For i = 2 To NewBook.Worksheets.Count NumberSheets(i) = i Next i Application.DisplayAlerts = False With NewBook .Sheets(1).Range("A1:C1").Interior.ColorIndex = 35 .Sheets(NumberSheets).Delete .SaveAs Filename:=MyPath .Close End With Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub ولنشرح الكود خطوة خطوة: Dim EndRow As Long Dim MyPath As String Dim NumberSheets() As Integer Dim i As Integer في الأسطر السابقة قمنا بتعريف المتغيرات كلٌ حسب طبيعة البيانات التي يحتاجها. Application.ScreenUpdating = False هنا ألغينا خاصية تحديث الشاشة ، وذلك حتى لا تبدو لنا التغييرات التي تحدث في الملف المنشئ (أثناء تنفيذ الكود) هذا من جهة ، ولتسريع الكود من جهة أخرى. Set NewBook = Workbooks.Add هنا قمنا بإنشاء مصنف جديد وأسندنا مرجعه في المتغير NewBook. With NewBook.Sheets(1) .Name = "أوائل الصفوف" .Cells(1, 1).Value = "اسم الطالب" .Cells(1, 2).Value = "الفصل" .Cells(1, 3).Value = "مجموع العلامات" End With هنا قمنا بتسمية أول ورقة في المصنف الجديد باسم (أوائل الصفوف) وقمنا بتسمية الخلايا A1 ، B1 ، C1 الموجودة في الورقة الأولى بـ ( اسم الطالب ، الفصل ، مجموع العلامات ) على الترتيب. ولإضافة رقم الجلوس ما عليك سوى إضافة سطر أخر تقوم فيه بتسمية الخلية D1 بـ أرقام الجلوس ، وذلك كما يلي: With NewBook.Sheets(1) .Name = "أوائل الصفوف" .Cells(1, 1).Value = "اسم الطالب" .Cells(1, 2).Value = "الفصل" .Cells(1, 3).Value = "مجموع العلامات" .Cells(1, 4).Value = "أرقام الجلوس" End With ويمكنك تغيير هذا الترتيب بتغيير الأرقام الموجودة في الهدف Cells كما تريد. For Each MySheet In Workbooks("الصف الأول الإعدادي").Worksheets هنا توجد لدينا حلقة تكرارية تسند في كل دورة مرجع لورقة معينة من المصتف في المتغير MySheet وذلك إلى أن تنتهي الأوراق الموجودة في مصنف "الصف الأول الإعدادي". For Each MyCell In MySheet.Range("I5:I24").Cells هنا توجد لدينا حلقة تكرارية تسند في كل دورة مرجع لخلية معينة من المجال I5:I24 الموجود داخل الورقة MySheet في المتغير MyCell وذلك إلى أن تنتهي الخلايا الموجودة في هذا المجال. If MySheet.Cells(MyCell.Row, 10).Value = "ناجح" Then هنا يتم اختبار الخلية المقابلة للخلية MyCell في العامود العاشر ومعرفة إذا كانت تحقق الشرط "ناجح" فإذا كان الشرط محقق يتم الانتقال للشرط الذي يليه. If MyCell.Value = MySheet.Cells(5, 12).Value Or MyCell.Value = MySheet.Cells(6, 12).Value Or MyCell.Value = MySheet.Cells(7, 12).Value Or MyCell.Value = MySheet.Cells(8, 12).Value Or MyCell.Value = MySheet.Cells(9, 12).Value Then هنا يتم اختبار القيمة الموجودة في الخلية MyCell فإذا كانت من ضمن العلامات الخمس الأوائل فإنه يتم الانتقال للسطر التالي. EndRow = NewBook.Sheets(1).Range("A1").CurrentRegion.Rows.Count هنا يتم إسناد رقم آخر سطر من نطاق البيانات الموجود في ورقة أوائل الصفوف وفي الملف الجديد في المتغير EndRow ، والهدف من هذا السطر هو الحيلولة دون الكتابة فوق البيانات القديمة. NewBook.Sheets(1).Cells(EndRow + 1, 1).Value = MySheet.Cells(MyCell.Row, 2).Value هنا يتم وضع القيمة المقابلة للخلية MyCell في العامود الثاني B من الملف القديم (عامود الاسم) في أول خلية موجودة بعد نطاق البيانات في الملف الجديد و في العامود A(عامود اسم الطالب). NewBook.Sheets(1).Cells(EndRow + 1, 2).Value = MySheet.Name هنا يتم وضع اسم الورقة MySheet من الملف القديم في أول خلية موجودة بعد نطاق البيانات في الملف الجديد و في العامود B(عامود الفصل). NewBook.Sheets(1).Cells(EndRow + 1, 3).Value = MyCell.Value هنا يتم وضع قيمة الخلية MyCell من الملف القديم في أول خلية موجودة بعد نطاق البيانات في الملف الجديد و في العامود C(عامود مجموع العلامات). وبفرض أن رقم الجلوس موجود في العمود K من الملف القديم ، فيجب عليك إضافة السطر التالي: NewBook.Sheets(1).Cells(EndRow + 1, 4).Value = MySheet.Cells(MyCell.Row, 11).Value هنا يتم وضع القيمة المقابلة للخلية MyCell في العامود الحادي عشر K من الملف القديم (عامود رقم الجلوس) في أول خلية موجودة بعد نطاق البيانات في الملف الجديد و في العامود D(عامود رقم الجلوس). With NewBook.Sheets(1).Range(Cells(1, 1), Cells(EndRow + 1, 3)) .Sort Key1:=NewBook.Sheets(1).Range("C2"), Order1:=xlDescending .Borders().LineStyle = xlContinuous .Borders().Weight = xlThin .Borders().ColorIndex = xlAutomatic .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .EntireColumn.AutoFit .Interior.ColorIndex = 34 End With هنا قمنا ببعض التعديلات على جدول البيانات الناتج ، وهي على الترتيب: - القيام بفرز تنازلي للبيانات بالاعتماد على عامود مجموع العلامات. - إحاطة خلايا الجدول بحدود على هيئة خطوط متصلة. - تحديد خط التحديد على أنه خط مفرد رفيع. - تحديد لون خط التحديد على أنه تلقائي. - عمل محاذاة أفقية لبيانات الجدول. - عمل محاذاة عاموديه لبيانات الجدول. - احتواء مناسب لبيانات الجدول (تغيير عرض الأعمدة لتستوعب البيانات الموجودة). - تعبئة خلايا الجدول باللون 34. وهنا يجب الملاحظة على ضرورية توسيع حيز تأثير الكود السابق في حالة استخدام أربعة أعمدة ، وذلك عن طريق تغيير السطر: With NewBook.Sheets(1).Range(Cells(1, 1), Cells(EndRow + 1, 3)) إلى السطر: With NewBook.Sheets(1).Range(Cells(1, 1), Cells(EndRow + 1, 4)) نتابع شرح الكود... MyPath = Workbooks("الصف الأول الإعدادي").Path & "\أوائل الصفوف" هنا قمنا بإسناد مسار الملف الجديد في المتغير MyPath (وذلك لاستخدامه لا حقاً عند حفظ الملف) ، وذلك بتسمية المسار الجديد بالاسم "أوائل الصفوف" ووضعه في نفس مسار الملف القديم. ReDim NumberSheets(2 To NewBook.Worksheets.Count) For i = 2 To NewBook.Worksheets.Count NumberSheets(i) = i Next i هنا قمنا بوضع مراجع الأوراق الزائدة في الملف الجديد في مصفوفة ديناميكية (وذلك لاستخدامها لاحقاً في حذف الأوراق الزائدة). Application.DisplayAlerts = False هنا قمنا بإلغاء خاصية إرسال الرسائل للمستخدم. With NewBook .Sheets(1).Range("A1:C1").Interior.ColorIndex = 35 .Sheets(NumberSheets).Delete .SaveAs Filename:=MyPath .Close End With هنا قمنا ببعض التعديلات على الملف الجديد ، وهي بالترتيب: - تلوين ترويسة الجدول باللون 35. - حذف الأوراق الزائدة (التي توجد مراجعها داخل المصفوفة NumberSheets) - حفظ الملف الجديد بالمسار الموجود في المتغير MyPath. - إغلاق الملف الجديد. Application.DisplayAlerts = True Application.ScreenUpdating = True إعادة الخاصيتين السابقتين للعمل. وهنا يوجد تساؤل ، لماذا ألغينا الخاصية DisplayAlerts؟ لقد قمنا بإلغاء هذه الخاصية من أجل تجاهل الرسالة التي تخبرنا بتأكيد حذف الأوراق الزائدة في الملف الجديد وبالرسالة التي تخبرنا بتأكيد الحفظ فوق ملف قديم موجود مسبقاً. ولكن ماذا لو أردنا تجاهل رسالة تأكيد حذف الأوراق الزائدة مع الإبقاء على رسالة تأكيد التسجيل فوق ملف قديم؟ الحل بسيط ، ويكمن بتعديل الكود: Application.DisplayAlerts = False With NewBook .Sheets(1).Range("A1:C1").Interior.ColorIndex = 35 .Sheets(NumberSheets).Delete .SaveAs Filename:=MyPath .Close End With Application.DisplayAlerts = True Application.ScreenUpdating = True إلى الكود: With NewBook .Sheets(1).Range("A1:C1").Interior.ColorIndex = 35 Application.DisplayAlerts = False .Sheets(NumberSheets).Delete Application.DisplayAlerts = True .SaveAs Filename:=MyPath .Close End With Application.ScreenUpdating = True بالتوفيق

السلام عليكم ... الملف كما طلبت : تحياتي Book11111.zip

السلام عليكم ... جرب الكود التالي: Sub MySort() Dim MyValue As Double MyValue = Application.InputBox(prompt:="أدخل القيمة", Type:=1) For Each MyCell In Worksheets("Master").Range("H9:I22") If MyCell.Value > MyValue Then MyCell.Value = MyCell.Value - 50 Else MyCell.Value = MyCell.Value + 50 End If Next MyCell Worksheets("Master").Range("H9:I22").Sort Key1:=Worksheets("Master").Range("H9"), Order1:=xlAscending, Header:=xlGuess End Sub الكود السابق يقوم بطرح 50 من قيمة الخلية في حال كون قيمتها أكبر من الرقم المحدد ، ويقوم بإضافة 50 إلى قيمة الخلية في حال كون قيمتها أصغر من أو تساوي الرقم المحدد.

السلام عليكم ... تحياتي للأخ حسام نور ، وبالفعل فقد استوحيت من مثالك الطريقة الموجودة في الكود التالي: Sub MySearsh() Dim Searsh As String Dim FirstValue As String Dim NextValue As String Searsh = Application.InputBox(prompt:="أدخل قيمة البحث", Title:="بحث عن كلمة", Type:=2) For Each Sh In Worksheets With Sh If .Cells.Find(What:=Searsh, After:=ActiveCell) Is Nothing Then GoTo 1 .Activate With .Cells.Find(What:=Searsh, After:=ActiveCell) .Activate FirstValue = .Address End With Do If .Cells.FindNext(After:=ActiveCell) Is Nothing Then GoTo 1 If MsgBox("هل تريد البحث عن نتيجة أخرى", vbYesNo, "البحث عن التالي") = vbNo Then Exit Sub With .Cells.FindNext(After:=ActiveCell) .Activate NextValue = .Address End With Loop Until FirstValue = NextValue End With 1 Next Sh End Sub تحياتي

السلام عليكم ... يمكنك عمل ذلك ولكن سؤالك فيه الكثير من العمومية ، هل تريد منا أن نصمم لك البرنامج بصورة كاملة ؟ على أيه حال ، ابدأ بالبرنامج وسنجيبك عن أية أسئلة تواجهك. على ما أذكر فإنه يوجد في المنتدى مشاركة مشابهة عن الدوري السعودي ، ابحث عنها.

السلام عليكم ... واووووووووووووووووو :o 80 سنة على أية حال ، فأنا لا أعتقد بالأبراج في المرة :pp:

السلام عليكم ... طيب راجع الموضوع التالي ، واسئلني عن أي شيئ غامض فيه: http://office.microsoft.com/ar-sa/assistan...1995161025.aspx