أبومروان

والسلام عليكم ورحمة الله وبركاته جرب الكود التالي لعله المطلوب Sub Print25RowsPerPage() Dim wsSource As Worksheet Dim rowCount As Long Dim rowsPerPage As Long Dim i As Long Dim printRange As Range Dim pageNum As Long ' تحديد ورقة العمل المصدر Set wsSource = ThisWorkbook.Sheets("ورقة1") ' تأكد من تغيير اسم الورقة إلى الورقة المناسبة rowCount = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row ' حساب عدد الصفوف rowsPerPage = 25 ' عدد الصفوف في كل ورقة pageNum = 1 ' لتتبع رقم الصفحة أثناء الطباعة ' التكرار عبر الصفوف وتقسيمها على أوراق الطباعة For i = 1 To rowCount Step rowsPerPage ' تحديد نطاق الطباعة (25 صفًا لكل ورقة) Set printRange = wsSource.Rows(i & ":" & WorksheetFunction.Min(i + rowsPerPage - 1, rowCount)) ' تعيين نطاق الطباعة wsSource.PageSetup.PrintArea = printRange.Address ' تعيين إعدادات الطباعة (اختياري: إذا كنت تريد تغيير إعدادات الطباعة) With wsSource.PageSetup .Orientation = xlPortrait ' وضع الصفحة عمودي (يمكنك تغييره إلى xlLandscape إذا أردت الوضع الأفقي) .FitToPagesWide = 1 ' تأكد من طباعة الصفحة على عرض واحد .FitToPagesTall = False ' لا تحدد عدد الصفوف على الصفحة .LeftHeader = "صفحة " & pageNum ' عنوان الصفحة End With ' طباعة النطاق المحدد wsSource.PrintOut ' تحديث رقم الصفحة pageNum = pageNum + 1 Next i

وعليكم السلام ورحمه الله وبركاته بعد اذن استاذي @عبدالله بشير عبدالله حل اخر بالمعادلات =IF(ISNA(VLOOKUP(A1, 'إزالة من القائمة'!A:A, 1, FALSE)), "إبقاء", "إزالة")

وعليكم السلام ورحمه الله وبركاته ممكن تستخدم الكود التالي لعله المطلوب Sub ColorCellsAboveYellow() Dim ws As Worksheet Dim cell As Range Dim targetColor As Long Dim i As Integer Set ws = ThisWorkbook.Sheets("Sheet1") targetColor = RGB(255, 255, 0) For Each cell In ws.UsedRange If cell.Interior.Color = targetColor Then For i = 1 To 2 If cell.Row - i > 0 Then ws.Cells(cell.Row - i, cell.Column).Interior.Color = targetColor End If Next i End If Next cell End Sub Book1.xlsm

شغاله عندي بدون ادني مشكله

وعليكم السلام ورحمه الله وبركاته اتفضل استاذ @mahmoud nasr alhasany ارجو ان يكون هذا هو المطلوب وليك الاكواد المستخدمه لتفعيل f4 يجب الوفقوف علي textbox3 وسيتم تشغيل الكود المجود فيه كما ترا ادناه Private Sub TextBox3_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 115 Then CommandButton1_Click ' هنا ضع الامر الذي تريد تنفيذه بعد الضغط على زر انتر End If End Sub لتفعيل f4 يجب الوفقوف علي ListBox1 وسيتم تشغيل الكود المجود فيه كما ترا ادناه Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 113 Then CommandButton2_Click ' هنا ضع الامر الذي تريد تنفيذه بعد الضغط على زر انتر End If End Sub شاشة عميل بحث.xlsm شاشة عميل بحث.xlsm

هذه المشكلة تحدث عادةً بسبب اختلاف الترميز بين الملف الأصلي وبرنامج Excel الذي تستخدمه. قد تكون النصوص مكتوبة بترميز معين (مثل ANSI) بينما يستخدم Excel ترميزًا آخر (مثل UTF-8). لحل هذه المشكلة، يمكنك محاولة حفظ الملف بتنسيق جديد يدعم الترميز الصحيح. إليك كيفية القيام بذلك: 1. **فتح الملف في Excel:** - افتح الملف بامتداد `.xls` في Excel. 2. **حفظ الملف بتنسيق جديد:** - اذهب إلى قائمة **File** (ملف). - اختر **Save As** (حفظ باسم). - في نافذة الحفظ، اختر تنسيق الملف **.xlsx** من القائمة المنسدلة. - احفظ الملف بهذا التنسيق الجديد. 3. **إعادة فتح الملف:** - اغلق الملف وافتح النسخة المحفوظة بتنسيق `.xlsx`. إذا استمرت المشكلة بعد ذلك، يمكنك محاولة استخدام **Notepad** لتحويل الترميز: 1. **فتح الملف في Notepad:** - افتح الملف بامتداد `.xls` في Notepad (قد تحتاج إلى تغيير امتداد الملف مؤقتًا إلى `.txt`). 2. **حفظ الملف بترميز جديد:** - في Notepad، اذهب إلى قائمة **File** (ملف) واختر **Save As** (حفظ باسم). - اختر **UTF-8** من قائمة الترميز في أسفل نافذة الحفظ. - احفظ الملف بهذا التنسيق الجديد. 3. **إعادة تسمية الملف وفتحه في Excel - قم بإعادة تسمية الملف إلى امتداده الأصلي `.xls` وافتحه في Excel.

السلام عليكم ورحمه الله وبركاته ما هو التعديل المطلوب بالتحديد ملف المدرسة كامل الفصول 2024-2023.7z

وعليكم السلام تأكد من أن إعدادات اللغة في Excel تدعم العربية. استخدم ترميز Unicode عند حفظ الملف لتجنب فقدان النصوص. قم بتحديث Excel إلى أحدث إصدار. إصلاح الملف باستخدام أداة الإصلاح إذا كان الملف تالفًا. تأكد من إعدادات اللغة في Windows إذا كانت المشكلة مستمرة.

وعليكم السلام ورحمه الله وبركاته ارجو ان يكون المطلوب كود الترقيم Sub NumberRows() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Set ws = ThisWorkbook.Sheets("ورقة1") lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row For i = 2 To lastRow ws.Cells(i, "A").Value = i - 1 Next i End Sub كود التصفيه بعد التعديل Sub DeleteRows() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim deleteCount As Long Dim response As VbMsgBoxResult Set ws = ThisWorkbook.Sheets("ورقة1") ' تحديث العمود الذي يتم حساب آخر صف فيه من A إلى B lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row deleteCount = 0 response = MsgBox("هل أنت متأكد أنك تريد حذف من استلمو الاول والثاني", vbYesNo + vbQuestion, "تأكيد الحذف") If response = vbYes Then ' بدأ من الصف الأخير حتى الصف 3 كما في الكود الأصلي For i = lastRow To 3 Step -1 ' العمل على العمود B و C للتحقق من وجود القيم قبل حذف الصف If ws.Cells(i, 2).Value <> "" And ws.Cells(i, 3).Value <> "" Then ws.Rows(i).Delete deleteCount = deleteCount + 1 End If Next i MsgBox deleteCount & " صفوف تم حذفها.", vbInformation, "عملية الحذف" Else MsgBox "تم إلغاء عملية الحذف.", vbInformation, "إلغاء" End If ' تنسيق النصوص في النطاق B1:D50 بدلاً من A1:D50 With ws.Range("B1:D50").Font ' تغيير النطاق ليشمل العمود B بدلاً من A .Name = "Arial" .Size = 16 .Bold = True .Color = RGB(0, 0, 251) ' الأزرق End With ' إعداد الهوامش للطباعة With ActiveSheet.PageSetup .TopMargin = Application.InchesToPoints(0.5) .BottomMargin = Application.InchesToPoints(0.5) .LeftMargin = Application.InchesToPoints(0.5) .RightMargin = Application.InchesToPoints(0.5) End With ' كتابة التاريخ في العمود B (تم تحديثه من العمود A) ws.Range("B1").Value = Date - 1 ws.Range("B1").NumberFormat = "dd/mm/yyyy" ' إزاحة التاريخ اليومي لكتابة اليوم في العمود A ws.Range("A1").Value = Format(Date - 1, "dddd") NumberRows End Sub كود حذف وتنسيق وادراج (1).xlsm

السلام عليكم ورحمه الله وبركاته علي ما قدر مافهمت المطلوب =VLOOKUP(B2,البيانات!$A$2:$G$15,MATCH(C2,البيانات!$A$1:$G$1,0),0)

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

جزاك الله كل خير على قدر أهل العزم تأتي العزائم وتأتي على قدر الكرام المكارم وتعظم في عين الصغير صغارها وتصغر في عين العظيم العظائم

جزاك الله كل خير على قدر أهل العزم تأتي العزائم وتأتي على قدر الكرام المكارم وتعظم في عين الصغير صغارها وتصغر في عين العظيم العظائم

جزاك الله كل خير على قدر أهل العزم تأتي العزائم وتأتي على قدر الكرام المكارم وتعظم في عين الصغير صغارها وتصغر في عين العظيم العظائم

جزاك الله كل خير على قدر أهل العزم تأتي العزائم وتأتي على قدر الكرام المكارم وتعظم في عين الصغير صغارها وتصغر في عين العظيم العظائم

وعليكم السلام Function JoinUniqueValues(lookupValue As Variant, lookupRange As Range, returnRange As Range) As String Dim dict As Object Set dict = CreateObject("Scripting.Dictionary") Dim i As Long Dim result As String ' إنشاء قاموس لتخزين القيم الفريدة For i = 1 To lookupRange.Count If lookupRange.Cells(i, 1).Value = lookupValue Then If Not dict.exists(returnRange.Cells(i, 1).Value) Then dict.Add returnRange.Cells(i, 1).Value, Nothing End If End If Next i ' دمج القيم الفريدة باستخدام فاصلة result = Join(dict.keys, ", ") JoinUniqueValues = result End Function لاستخدام هذا الكود، قم بإضافته إلى وحدة VBA في Excel، ثم استخدم الدالة في ورقة العمل كالتالي: =JoinUniqueValues(I3, $A$4:$A$1200, $B$4:$B$1200) TEST CODE.xlsm

وعليكم السلام ورحمه الله وبركاته يمكنك الافضل استخدام PivotTable TEST.xlsm TEST.xlsm

السلام عليكم ورحمه الله

طيب ما ممكن نخلي مثلا صوره الطباعه في خليه B1 وعنمل اضافه تعليق علي الخليه لعله يفيد حضرتك

اليك حل اخر بالاكواد لعله يفيد حضرتك وممكن تعدل عليه علي حسب رغبه حضرتك Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim hijriDate As String ' تعيين الورقة النشطة Set ws = ThisWorkbook.Sheets("Sheet1") ' تأكد من تغيير اسم الورقة إذا كان مختلفًا ' التحقق إذا كان التغيير في النطاق X3 إلى آخر خلية تحتوي على بيانات If Not Intersect(Target, ws.Range("X3:X" & ws.Cells(ws.Rows.Count, "X").End(xlUp).Row)) Is Nothing Then ' العثور على آخر صف يحتوي على بيانات في العمود X lastRow = ws.Cells(ws.Rows.Count, "X").End(xlUp).Row ' تكرار عبر الصفوف من X3 إلى آخر صف For i = 3 To lastRow ' قراءة التاريخ الهجري من الخلية hijriDate = ws.Cells(i, "X").Value ' التحقق إذا كانت الخلية تحتوي على تاريخ If hijriDate <> "" Then ' التحقق إذا كان حرف "هـ" موجودًا بالفعل If InStr(hijriDate, "هـ") = 0 Then ' تحويل التاريخ إلى التنسيق المطلوب وإضافة حرف "هـ" ws.Cells(i, "X").Value = Format(hijriDate, "yyyy/mm/dd") & "هـ" End If End If Next i End If End Sub مثل التاريخ.xlsm

السلام عليكم ورحمه الله وبركاته يمكنك استخدام صيغة. إليك كيفية القيام بذلك: في خلية فارغة، أدخل التاريخ بالتنسيق 1446/05/01. في خلية أخرى، استخدم الصيغة التالية =TEXT(A1, "yyyy/mm/dd") & "هـ" حيث A1 هي الخلية التي تحتوي على التاريخ. اضغط على Enter. ستظهر النتيجة بالتنسيق 1446/05/01هـ. إذا كنت تفضل، يمكنك أيضًا إدخال التاريخ مباشرة مع "هـ" كما يلي: اكتب في الخلية: 1446/05/01هـ. لكن تذكر أن ذلك سيعطي Excel نصًا وليس تاريخًا، لذلك ستفقد بعض وظائف التاريخ. استخدام الصيغة هو الخيار الأفضل إذا كنت تحتاج إلى التعامل مع التواريخ بشكل أكبر

وعليكم السلام ورحمه الله وبركاته ممكن تستخدم HYPERLINK زسيظهر لك كما في الصور ادناه. ارجو ان يكون المطلوب وليك الشرح 1/232/ wor.xlsm wor.xlsm

وعليكم السلام ورحمه الله بعد اذن استاذنا @عبدالله بشير عبدالله يسعدني أن أشارك معكم هذه التجربة في محاولة مني للمساهمة والتفاعل الإيجابي والاستفاده من حضرتكم. Sub نقل_الأعمدة() Dim wsSource As Worksheet Dim wsFirst As Worksheet Dim wsSecond As Worksheet Dim wsThird As Worksheet Dim lastRow As Long ' تعيين ورقة المصدر Set wsSource = ThisWorkbook.Sheets("الرئيسية") ' تعيين أوراق العمل الأخرى Set wsFirst = ThisWorkbook.Sheets("الأولى") Set wsSecond = ThisWorkbook.Sheets("الثانية") Set wsThird = ThisWorkbook.Sheets("الثالثة") ' العثور على آخر صف في ورقة المصدر lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row ' نقل الأعمدة إلى الورقة الأولى wsSource.Range("A1:A" & lastRow).Copy wsFirst.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("D1:D" & lastRow).Copy wsFirst.Range("B1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("F1:F" & lastRow).Copy wsFirst.Range("C1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("AB1:AB" & lastRow).Copy wsFirst.Range("D1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("AC1:AC" & lastRow).Copy wsFirst.Range("E1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats ' نقل الأعمدة إلى الورقة الثانية wsSource.Range("A1:F" & lastRow).Copy wsSecond.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("AT1:AT" & lastRow).Copy wsSecond.Range("G1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats ' نقل الأعمدة إلى الورقة الثالثة wsSource.Range("A1:A" & lastRow).Copy wsThird.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("D1:D" & lastRow).Copy wsThird.Range("B1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("F1:F" & lastRow).Copy wsThird.Range("C1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("Q1:Q" & lastRow).Copy wsThird.Range("D1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("R1:R" & lastRow).Copy wsThird.Range("E1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("AB1:AR" & lastRow).Copy wsThird.Range("F1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats ' تنظيف الحافظة Application.CutCopyMode = False MsgBox "تم نقل الأعمدة بنجاح!", vbInformation End Sub