Saleh Ahmed Rabie

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

للرفع

للرفع

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

**كود VBA لترتيب الأسماء أبجديًا** Sub SortNamesAlphabetically() Dim rng As Range Dim lastRow As Long ' تحديد نطاق البيانات Set rng = Range("A1:A100") ' تعديل النطاق حسب الحاجة ' الحصول على آخر صف في النطاق lastRow = rng.Rows.Count ' فرز النطاق أبجديًا rng.Sort Key1:=rng.Columns(1), Order1:=xlAscending, Header:=xlYes End Sub **كود VBA لترتيب المجموع تنازليًا** Sub SortSumDescending() Dim rng As Range Dim lastRow As Long ' تحديد نطاق البيانات Set rng = Range("A1:B100") ' تعديل النطاق حسب الحاجة ' الحصول على آخر صف في النطاق lastRow = rng.Rows.Count ' فرز النطاق تنازليًا حسب المجموع في العمود B rng.Sort Key1:=rng.Columns(2), Order1:=xlDescending, Header:=xlYes End Sub **ملاحظات:** * تأكد من تعديل نطاقات البيانات في أكواد VBA لتتوافق مع نطاق بياناتك الفعلي. * يمكنك استخدام هذه الأكواد لترتيب البيانات في أي نطاق من ورقة العمل. * إذا كنت ترغب في فرز البيانات حسب معايير متعددة، يمكنك استخدام طريقة `Sort` مع معلمات `Key2` و`Order2` و`Key3` و`Order3` وما إلى ذلك.

وعليكم السلام Sub Logi1nNew_URL() Dim ie As Object Dim element As Object Dim str1 As String Dim str2 As String Dim str3 As String Dim lRow As Long ' Set Internet Explorer as default browser Set ie = CreateObject("Shell.Application").Windows("iexplore.exe") With Sheets("Sheet1") str1 = .Range("ac2").Value str2 = .Range("ad2").Value str3 = .Range("ae2").Value End With With ie .Visible = True .Navigate "http://student.moe.gov.eg/new/serch_students.aspx" Do Until .ReadyState = 4 DoEvents Loop On Error Resume Next .Document.All.Item("ctl00$ContentPlaceHolder1$TextBox1").Value = str1 .Document.All.Item("ctl00$ContentPlaceHolder1$TextBox2").Value = str2 .Document.All.Item("ctl00$ContentPlaceHolder1$TextBox3").Value = str3 For Each element In .Document.getElementsByTagName("input") If element.Type = "submit" Then element.Click Exit For End If Next element End With End Sub

وعليكم السلام **ملاحظة:** من المحتمل أن يكون سبب الخطأ هو أن اسم ورقة العمل `sheetName` غير صحيح أو غير موجود في المصنف. * تأكد من استبدال `[Book1]Sheet1` في السطر `SubAddress:="'[Book1]Sheet1'!" & cell.Address` باسم ورقة العمل الحقيقية التي تحتوي على النطاق `cellAddress`. * يمكنك أيضًا إضافة معالجة إضافية للتعامل مع الحالات الأخرى، مثل عندما تكون ورقة العمل أو النطاق محميًا أو مخفيًا.

**كود VBA لإظهار "راسب" للطلاب الذين لم يحصلوا على ربع درجة النجاح في الترم الثاني** Sub CheckPassFail() Dim ws As Worksheet Set ws = ThisWorkbook.Worksheets("Sheet1") 'استبدل "Sheet1" باسم ورقة العمل الخاصة بك Dim lastRow As Long lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow If ws.Cells(i, "D").Value < 5 Then 'عمود الدرجات ws.Cells(i, "E").Value = "راسب" 'عمود النتيجة End If Next i End Sub **خطوات الاستخدام:** 1. انسخ الكود والصقه في وحدة نمطية في دفتر عمل Excel الخاص بك. 2. استبدل "Sheet1" في سطر `Set ws = ThisWorkbook.Worksheets("Sheet1")` باسم ورقة العمل التي تحتوي على بيانات الطلاب. 3. قم بتشغيل الكود بالنقر فوق الزر "تشغيل" في علامة التبويب "المطور" أو باستخدام اختصار لوحة المفاتيح `F5`. **ملاحظات:** * يفترض الكود أن عمود الدرجات هو العمود "D" وعمود النتيجة هو العمود "E". * إذا لم يكن لديك عمود نتيجة، يمكنك إضافة واحد يدويًا أو تعديل الكود لتحديث عمود آخر. * يمكنك تخصيص الكود لتناسب احتياجاتك المحددة، مثل تغيير قيمة درجة النجاح أو تغيير النص الذي يتم عرضه للطلاب الراسبين.

وعليكم السلام ورحمة الله وبركاته **كود VBA لفصل محتوى الخلية إلى جزئين (الوصف والكود):** Sub SplitCellContent() Dim rng As Range Dim arrContent() As String Dim strDescription As String Dim strCode As String ' تحديد الخلية التي تحتوي على المحتوى الذي تريد فصله Set rng = Range("A2") ' تقسيم المحتوى إلى مصفوفة من السلاسل arrContent = Split(rng.Value, " ") ' استخراج الوصف والكود من المصفوفة strDescription = arrContent(0) strCode = arrContent(1) ' وضع الوصف والكود في خلايا منفصلة rng.Offset(0, 1).Value = strDescription rng.Offset(0, 2).Value = strCode End Sub **مثال:** إذا كان محتوى الخلية A2 هو: جهاز كمبيوتر محمول HP EliteBook 840 G8 فسيؤدي تشغيل كود VBA هذا إلى فصل المحتوى إلى الخليتين B2 وC2 على النحو التالي: * **B2:** جهاز كمبيوتر محمول HP EliteBook 840 G8 * **C2:** 840 G8 **ملاحظة:** * يمكنك تعديل كود VBA لتناسب احتياجاتك الخاصة، مثل تغيير الخلية التي تحتوي على المحتوى أو تغيير الفاصل المستخدم لفصل الوصف والكود. * يمكنك أيضًا استخدام كود VBA لفصل محتوى الخلية إلى أكثر من جزئين.

**تحليل الخطأ:** يحدث خطأ "Subscript out of range" عندما يحاول الكود الوصول إلى عنصر خارج نطاق المصفوفة أو المجموعة. في هذه الحالة، يبدو أن الخطأ يحدث في السطر التالي: ``` If Sheets(sheetName).Range(cellAddress) = "" Then ``` **الحل:** من المحتمل أن يكون سبب الخطأ هو أن ورقة العمل `sheetName` لا تحتوي على نطاق `cellAddress`. للتحقق من ذلك، يمكنك إضافة سطرين للتحقق من وجود ورقة العمل والنطاق قبل محاولة الوصول إليهما. **الكود المعدل:** ``` Private Sub Worksheet_Change(ByVal Target As Range) Dim cell As Range Dim formula As String, sheetName As String, cellAddress As String For Each cell In Target If InStr(cell.Formula, "=") > 0 Then formula = Mid(cell.Formula, InStr(cell.Formula, "=") + 1, Len(cell.Formula) - InStr(cell.Formula, "=")) If InStr(formula, "!") > 0 Then sheetName = Mid(formula, 2, InStr(formula, "!") - 2) cellAddress = Mid(formula, InStr(formula, "!") + 1, Len(formula) - InStr(formula, "!")) If Sheets(sheetName).Exists Then If Sheets(sheetName).Range(cellAddress).Exists Then If Sheets(sheetName).Range(cellAddress) = "" Then cell.Hyperlinks.Add Anchor:=cell, Address:="", SubAddress:="", TextToDisplay:=cell.Value Else Sheets(sheetName).Range(cellAddress).Hyperlinks.Add Anchor:=Sheets(sheetName).Range(cellAddress), Address:="", SubAddress:="'[Book1]Sheet1'!" & cell.Address, TextToDisplay:=Sheets(sheetName).Range(cellAddress).Value End If End If End If End If End If Next cell End Sub ``` **ملاحظة:** * تأكد من استبدال `[Book1]Sheet1` في السطر `SubAddress:="'[Book1]Sheet1'!" & cell.Address` باسم ورقة العمل الحقيقية التي تحتوي على النطاق `cellAddress`. * يمكنك أيضًا إضافة معالجة إضافية للتعامل مع الحالات الأخرى، مثل عندما تكون ورقة العمل أو النطاق محميًا أو مخفيًا.

يمكنك استخدام الكود التالي في VBA لإضافة الDynamic Hyperlink بين خليتين في شيتين مختلفين: Private Sub Worksheet_Change(ByVal Target As Range) Dim cell As Range Dim formula As String, sheetName As String, cellAddress As String For Each cell In Target If InStr(cell.Formula, "=") > 0 Then formula = Mid(cell.Formula, InStr(cell.Formula, "=") + 1, Len(cell.Formula) - InStr(cell.Formula, "=")) If InStr(formula, "!") > 0 Then sheetName = Mid(formula, 2, InStr(formula, "!") - 2) cellAddress = Mid(formula, InStr(formula, "!") + 1, Len(formula) - InStr(formula, "!")) If Sheets(sheetName).Range(cellAddress) = "" Then cell.Hyperlinks.Add Anchor:=cell, Address:="", SubAddress:="", TextToDisplay:=cell.Value Else Sheets(sheetName).Range(cellAddress).Hyperlinks.Add Anchor:=Sheets(sheetName).Range(cellAddress), Address:="", SubAddress:="'[Book1]Sheet1'!" & cell.Address, TextToDisplay:=Sheets(sheetName).Range(cellAddress).Value End If End If End If Next cell End Sub ``` يرجى استبدال "Book1" في الكود بعنوان المصنف الخاص بك. يجب نسخ الكود ولصقه في قسم الكود للشيت الذي ترغب في تنفيذ الديناميكية الHyperlink فيه. سيقوم الكود بإضافة الDynamic Hyperlink بين الخليتين عند تحقق الشرط وسيتم تحديث الارتباطات تلقائيًا عند إجراء أية تغييرات.

وللحماية من فتح ملفات Excel على الجوال يمكنك استخدام الكود التالي في VBA: Private Sub Workbook_Open() If Application.OperatingSystem Like "*phone*" Then MsgBox "لا يمكن فتح هذا الملف على الهاتف الجوال", vbExclamation ThisWorkbook.Close SaveChanges:=False End If End Sub يقوم الكود بفحص نظام التشغيل الذي يعمل عليه Excel، وإذا كان النظام هو هاتف جوال فسيتم عرض رسالة تنبيه تخبر المستخدم بأنه لا يمكن فتح الملف على الهاتف الجوال وسيتم إغلاق الملف دون حفظ التغييرات. يمكنك إضافة هذا الكود في "ThisWorkbook" في محرر الفيجوال بيسيك لتطبيقه عند فتح الملف.

كود VBA لحذف الشيتات المخفية في ملف Excel عند محاولة فتحها في الجوال وعدم حذفها عند فتحها في اللابتوب: Private Sub Workbook_Open() Dim ws As Worksheet Dim deleteHiddenSheets As Boolean Dim operatingSystem As String operatingSystem = Application.OperatingSystem If operatingSystem Like "*phone*" Then deleteHiddenSheets = True Else deleteHiddenSheets = False End If If deleteHiddenSheets Then Application.DisplayAlerts = False For Each ws In ThisWorkbook.Sheets If ws.Visible = xlSheetHidden Then ws.Delete End If Next ws Application.DisplayAlerts = True End If End Sub يقوم هذه الكود بفحص نوع نظام التشغيل وفي حال كان النظام هو هاتف (جوال)، سيتم حذف جميع الشيتات المخفية. وإذا كان النظام ليس هاتف (مثل اللابتوب)، لن يتم حذف الشييتات المخفية. يمكنك استخدام هذا الكود في ملف Excel الخاص بك لتحقيق ذلك.

ويمكنك استخدام الكود التالي لمنع فتح ملف Excel عبر الجوال وإخفاء جميع الأوراق في الملف: Private Sub Workbook_Open() If Application.UserName = "اسم المستخدم هنا" And Application.OperatingSystem Like "*phone*" Then MsgBox "غير مسموح بفتح هذا الملف عبر الجوال", vbExclamation ThisWorkbook.Close False Else Dim ws As Worksheet For Each ws In ThisWorkbook.Sheets ws.Visible = xlSheetHidden Next ws End If End Sub يجب استبدال "اسم المستخدم هنا" بالاسم المستخدم الذي تريد منعه من فتح الملف عبر الجوال. يقوم الكود أولاً بالتحقق إذا كان المستخدم هو المستخدم المحدد وإذا كان نظام التشغيل هو الهاتف، سيتم عرض رسالة تنبيه وإغلاق الملف، وإلا سيتم إخفاء جميع الأوراق في الملف.

**وعليكم السلام ورحمة الله وبركاته** **كل عام وأنتم بخير وعافية** **نعم، يوجد كود برمجي لمنع فتح ملف Excel بواسطة الهاتف المحمول.** **إليك الكود:** ``` Private Sub Workbook_Open() If Application.Mobile Then MsgBox "Sorry, this workbook cannot be opened on a mobile device." Application.Quit End If End Sub ``` **كيفية استخدام الكود:** 1. افتح ملف Excel الخاص بك. 2. انقر فوق علامة التبويب "المطور". 3. انقر فوق "Visual Basic" لفتح محرر Visual Basic. 4. انقر بزر الماوس الأيمن فوق اسم المصنف في الجزء الأيسر من المحرر. 5. انقر فوق "عرض التعليمات البرمجية". 6. الصق الكود في نافذة التعليمات البرمجية. 7. احفظ المصنف. **عند محاولة فتح المصنف على جهاز محمول، ستظهر رسالة خطأ تفيد بأنه لا يمكن فتح المصنف.** **ملاحظة:** * هذا الكود يمنع فقط فتح المصنف على الأجهزة المحمولة. * لا يزال بإمكان المستخدمين عرض محتويات المصنف إذا قاموا بتحميله على جهاز كمبيوتر.