محمد هشام.

أستاذ مصطفى حاول أولا تنسيق حدود الطباعة للشيتات المراد طباعتها 2) هل تريد حفظ الشيتات بصيغة Pdf في مكان معين وطباعتها في نفس الوقت او الحفظ فقط

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي المصنف 2.xlsx

قم باظافة هدا السطر في اول الكود مع تبديل كلمة Password بالباسوورد الخاص بك WSDest.Unprotect "Password" وفي نهايته WSDest.Protect "Password"

كما يمكنك استخدام المعادلة التالية لجلب الغياب امام التاريخ =IFERROR(HLOOKUP(B5;غياب!$B$3:$AG$200;MATCH($D$3;غياب!$B$3:$B$200;0);0);"") TEST.rar

وعليكم السلام ورحمة الله تعالى وبركاته تفضل جرب اخي =IFERROR(INDEX(غياب!$C$3:$AG$3;MATCH($D$3;غياب!$B$5;0);MATCH(A5;غياب!$C$4:$AG$4;0));"") نقل التاريخ.xlsx

العفو اخي نحن سعداء باننا استطعنا مساعدتك شكرا لتعليقاتكم الرقيقة

وهدا اخر ملف قمت برفعه دون ان اغير اي شيء في الاكواد فقط حاول جعل الاسماء الغير معدلة درجاتهم في اخر قائمة الاسماء لكي يتطبق شرط وجود الاسماء المعدلة بشكل متتابع وسوف يشتغل معك الكود بشكل صحيح ‏‏مطابقة درجات V2.xlsm

Sub comparecells_V2() Dim i As Long, j As Long, k As Long Dim WSData As Worksheet: Set WSData = Sheets("الكشف") Dim WSDest As Worksheet: Set WSDest = Sheets("فرزدرجات") Application.ScreenUpdating = False k = 6 With WSData For i = 6 To .Range("D" & Rows.Count).End(3).Row Step 2 For j = 5 To .Cells(i, Columns.Count).End(1).Column If .Cells(i, j).Value <> .Cells(i + 1, j) Then .Rows(i & ":" & i + 1).Copy WSDest.Range("A" & k) k = k + 2 Exit For End If Next Next End With Application.ScreenUpdating = True End Sub اليك كود اخر يؤدي نفس المهمة فقط للتاكد من صحة الاكواد اخي لكي يشتغل معك الكود بشكل سليم يجب اولا تنظيم ملفك على الشكل التالي 1) لقد دكرت بان اسماء الطلاب مكررة مرتين في ملف الكشف كما جاء في ملفك المرفق. وقد اعتمدنا على هدا داخل الاكواد For i = 1 To UBound(a, 1) - 1 Step 2 يعني لابد من وجود الاسماء في وضعية متتابعة واحد تلو الاخر مع تطابق شكل كتابة الاسماء وهدا مثال على ملف اخر قمت بنسخ بياناتك عليه والتاكد من تطابق الاسماء يمكنك تجربته ووافينا بالنتيجة وهده صورة من ملفك بعد تنظيمه وحدف الاسماء الغير مكررة للتجربة TEST V2.xlsm وهدا ملفك يمكنك تجربته كدالك مطابقة درجات V2.xlsm

تفضل اخي جرب تم تعديل الكود لجلب بيانات جميع الطلاب بشرط اختلاف في اي درجة من درجات المواد ولو كانت واحدة فقط . وتجاهل من لهم درجات متطابقة في جميع المواد Sub comparecells_MH() Dim i&, j&, k&, m&, RwsDest&, derlig& Dim a As Variant, b As Variant Dim WSData As Worksheet: Set WSData = Sheets("الكشف") Dim WSDest As Worksheet: Set WSDest = Sheets("فرزدرجات") derlig = WSDest.Range("C" & Rows.Count).End(xlUp).Row + 1 Application.ScreenUpdating = False a = WSData.Range("C6:T" & WSData.Range("D" & Rows.Count).End(3).Row).Value ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)) For i = 1 To UBound(a, 1) - 1 Step 2 For j = 3 To UBound(a, 2) If a(i, j) <> a(i + 1, j) Then k = k + 1 For m = 1 To UBound(a, 2) b(k, m) = a(i, m) b(k + 1, m) = a(i + 1, m) Next k = k + 1 Exit For End If Next Next WSDest.Range("C6").Resize(UBound(b, 1), UBound(b, 2)).Value = b With WSDest.Range("C6:T" & WSDest.Cells.SpecialCells(xlCellTypeLastCell).Row) If .Row < 6 Then Exit Sub For Each r In .EntireRow If Application.CountA(Intersect(r, WSDest.Range("C:D"))) Then _ If Application.CountA(Intersect(r, WSDest.Range("E:T"))) = 0 Then Intersect(r, WSDest.Range("C:D")).EntireRow.Delete Next RwsDest = WSDest.Range("D" & Rows.Count).End(xlUp).Row With WSDest.Cells(6, Columns.Count).End(xlToLeft).Offset(0, 1).Resize(RwsDest) .Formula = "=if(countifs(D:D,D6)>1,"""",1)" .Value = .Value Intersect(.SpecialCells(xlConstants).EntireRow, WSDest.Range("A:U")).Delete WSDest.Range("U6:U" & derlig).ClearContents End With End With Application.ScreenUpdating = True End Sub مطابقة درجات V1.xlsm

( استدعاء هذا الطالب في ورقة فرز الدرجات التي عليها التنسيق الشرطي !!!!) هناك تناقض نوعا ما 1) داخل الملف ذكرت انك تريد جلب جميع الطلاب المختلفة درجاتهم دفعة واحدة مع تجاهل من هم درجاتهم متطابقة 2) في حالة كان الطالب غير مكرر اسمه هل يتم جلب بياناته او يتم تجاهلها يجب الإجابة على هذه الاستفسارات لنستطيع مساعدتك.

مادا تقصد بالفصل الاول والثاني الورقة عليها الفصل الاول فقط

تفضل جرب Sub زر1_انقر() Dim Lr As Long, i As Long, R As Long Dim txt Set sht = Worksheets("بحث") Set sht2 = Worksheets("قاموس") txt = sht.Range("B2") Application.ScreenUpdating = False sht.Range("B4:BM30000").ClearContents With sht2 Lr = .Cells(.Rows.Count, "B").End(xlUp).Row For i = Lr To 2 Step -1 If txt = CStr(.Cells(i, "B")) Then 'If txt = CStr(.Cells(i, "B")) Or txt = CStr(.Cells(i, "B")) Or InStr(CStr(.Cells(i, "B")), txt) Then sht.Cells(R + 4, "B").Resize(1, 3).Value = sht2.Cells(i, "B").Resize(1, 3).Value R = R + 1 If R = 40 Then Exit For End If Next End With Application.ScreenUpdating = True End Sub بحث عن طريق الضغط.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي الكريم ورقة القائمة الخلية(D2) =IFERROR(IF('النسب '!D3<>"";INDEX('النسب '!$D$3:$D$500;MATCH(0;COUNTIF($D$1:D1;'النسب '!$D$3:$D$500);0));"");"") ورقة الشغل القائمة المنسدلة لاسم العملية (G5) الخلية =OFFSET(القائمة!$D$2;0;0;COUNTA(القائمة!D:D)-1) القائمة المنسدلة للنسبة (H5) الخلية =OFFSET('النسب '!$F$3;0;0;COUNTA('النسب '!F:F)-1) (I5) الخلية =IF(H5<>"";INDEX('النسب '!$E$3:$E$500;MATCH(1;INDEX((الشغل!H5='النسب '!$F$3:$F$500)*(الشغل!G5='النسب '!$D$3:$D$500);0;1);0));"") بالتوفيق...... الصوب نسب2023 -V1.xlsm

العفو اخي حمل الملف من المرفقات ووافينا بالنتيجة

تمت تجرب الملف اكثر من مرة لم تظهر معي اي اخطاء اما بالنسبة sheet1 to trheel هدا الاسم موجود على ملف الاخ @ابوحبيبه لم اعلم من اين اتى به لان ملف السائل يحتوي فقط على شيت باسم sheet1 وورقة لشكل النتائج المطلوبة ممكن صورة للخطا لو سمحت

@lionheart فكره جميلة لاكن اعتقد انه من الضروري اضافة حذف الاوراق القديمة قبل تنفيذ الكود تفاديا لظهور رسالة خطأ With ws.Range("A3").CurrentRegion اما بالنسبة لهدا السطر في حالة كان هناك اي بيانات اخرى بجانب الجدول (مجرد احتمال) سيتم نسخها كدالك

@بلانك لم افهم مادا تقصد

وعليكم السلام ورحمة الله تعالى وبركاته Sub Unique_School() Dim rng As Range, cRng As Range Dim Cell As Range, LstRow As Long Dim wsDest As Variant, s As String Dim cUnique As Collection Dim LrDest As Integer, i As Integer Dim WorksheetExists As Boolean Set ws_Data = ThisWorkbook.Sheets("Sheet1") Set rng = ws_Data.Range("C4:C" & ws_Data.Cells(ws_Data.Rows.Count, "C").End(xlUp).Row) Set cUnique = New Collection Application.ScreenUpdating = False Application.DisplayAlerts = False For Each ws In Sheets If ws.Name <> ws_Data.Name Then ws.Delete Next On Error Resume Next For Each Cell In rng.Cells cUnique.Add Cell.Value, CStr(Cell.Value) Next Cell On Error GoTo 0 For Each wsDest In cUnique s = wsDest Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsDest ActiveSheet.DisplayRightToLeft = True With ws_Data LstRow = .Cells(.Rows.Count, "A").End(xlUp).Row .Range("A3").AutoFilter Field:=3, Criteria1:=wsDest Set cRng = .Range("A3:J" & LstRow) cRng.Copy Sheets(s).Range("A3") .Select .Range("A3").AutoFilter End With Next wsDest ws_Data.Activate Application.ScreenUpdating = True End Sub كشف طلاب المدارس 2.xlsm في حالة الرغبة باعادة انشاء تسلسل جديد للصفوف كشف طلاب المدارس 3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي اسم المستخدم : admin كلمة المرور : 1989 Option Compare Text Dim f, Rng, MH(), WS_Rng, DataRng Private Sub UserForm_Initialize() DataRng = "Tableau1" WS_Rng = Range(DataRng).Columns.Count MH = Range(DataRng).Resize(, WS_Rng + 1).Value For i = 1 To UBound(MH): MH(i, WS_Rng + 1) = i: Next i Me.ListBox1.List = MH Me.ListBox1.ColumnCount = WS_Rng + 1 Me.ListBox1.ColumnWidths = "70;110;100;100;100" Me.ComboBox1.List = Application.Transpose(Range(DataRng).Offset(-1).Resize(1)) Me.ComboBox1.ListIndex = 0 Me.B.Caption = "فلترة ب:" & Me.ComboBox1 Set d = CreateObject("scripting.dictionary") For i = 1 To UBound(MH) d(MH(i, 1)) = "" Next i WSdata = d.keys Me.ComboBox2.List = WSdata Sht = Application.Transpose(Range(DataRng).Offset(-1).Resize(1)) For i = 1 To WS_Rng Me("label" & i) = Sht(i, 1) Next i For i = WS_Rng + 1 To 6 Me("label" & i).Visible = False: Me("TextBox" & i).Visible = False Next i Me.ComboBox2 = "*" T_resultat = "عدد الموظفين" & "/" & ListBox1.ListCount + 0 Count = ListBox1.ListCount End Sub '''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Combobox1_click() Me.ListBox1.List = MH Me.B.Caption = "فلترة ب:" & Me.ComboBox1 Me.T.Caption = "بحث ب:" & Me.ComboBox1 Set Titre = Range(DataRng).Offset(-1).Resize(1) colFiltre = Application.Match(Me.ComboBox1, Titre, 0) Set d = CreateObject("scripting.dictionary") For i = 1 To UBound(MH) d(MH(i, colFiltre)) = "" Next i WSdata = d.keys Me.ComboBox2.List = WSdata Me.ComboBox2 = Empty End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub TextBoxRech_Change() On Error Resume Next WSdest = Me.ComboBox1.ListIndex + 1 clé = "*" & Me.TextBoxRech & "*": n = 0 Dim Tbl() For i = 1 To UBound(MH) If MH(i, WSdest) Like clé Then n = n + 1: ReDim Preserve Tbl(1 To UBound(MH, 2), 1 To n) For k = 1 To UBound(MH, 2): Tbl(k, n) = MH(i, k): Next k End If Next i If n > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.clear End Sub منظومة-الشؤون-الادارية.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub test() Dim lR&, lRow& Dim Y As Range, R As Range Dim wsCopy As Worksheet: Set wsCopy = Sheets("Sheet1") Dim wsDest As Worksheet: Set wsDest = Sheets("Sheet2") lRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).Row Application.ScreenUpdating = False wsDest.Range("B10:K" & lRow).ClearContents With wsCopy lR = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row .Range(.Cells(22, "B"), .Cells(lR, "E")).Copy wsDest.Cells(10, "B") End With With wsDest For Each Y In .Range("C10:C" & .Cells(Application.Rows.Count, 3).End(xlUp).Row) Set R = wsCopy.Columns(3).Find(Y.Value, , xlValues, xlPart) If Not R Is Nothing And R.Offset(0, 4).Value = "غ" Or R.Offset(0, 4).Value = "دون المستوى" Then Y.Offset(0, 3).Value = "X" If Not R Is Nothing And R.Offset(0, 6).Value = "غ" Or R.Offset(0, 6).Value = "دون المستوى" Then Y.Offset(0, 4).Value = "X" If Not R Is Nothing And R.Offset(0, 8).Value = "غ" Or R.Offset(0, 8).Value = "دون المستوى" Then Y.Offset(0, 5).Value = "X" If Not R Is Nothing And R.Offset(0, 10).Value = "غ" Or R.Offset(0, 10).Value = "دون المستوى" Then Y.Offset(0, 6).Value = "X" If Not R Is Nothing And R.Offset(0, 12).Value = "غ" Or R.Offset(0, 12).Value = "دون المستوى" Then Y.Offset(0, 7).Value = "X" If Not R Is Nothing And R.Offset(0, 14).Value = "غ" Or R.Offset(0, 14).Value = "دون المستوى" Then Y.Offset(0, 8).Value = "X" Next Y End With Application.ScreenUpdating = True End Sub OSAMA_V1.xlsm

نعم اخي ده مثال للفائدة فقط يمكنك تطويعه بما يناسبك وللعلم يمكن حدف اي ورقة من اوراق العمل سيقوم الملف بتحديث البيانات تلقائيا دون اي مشكلة اخي على العموم اليك الملف ب 3 اوراق فقط وورقة خاصة ب (Admin) لتعديل كلمات المرور test3.xlsm

بعد إذن الإخوة الكرام واثراءا للموضوع اليك اخي طريقتين يمكنك اختيار ما يناسيك الطريقة الاولى اظهار ورقة المستخدم بكلمة مرور مع اخفاء جميع الشيتات الاخرى يمكنك نعديل كلمات المرور كما تشاء الطريقة الثانية تحديد صلاحيات الوصول للمستخدمين دون اخفاء اوراق العمل بمعنى كتابة كلمة مفعل امام اوراق العمل المسموح للمستخدم الوصول اليها كما في الصورة المرفقة test1.rar test2.rar

وعليكم السلام ورحمة الله تعالى وبركاته اليك حل بديل بالاكواد اول خطوة قم بتسمية نطاق عمود التصنيف بالشكل التالي =OFFSET(التعريف!$E$3;;;COUNTA(التعريف!$E:$E)-1) 2) وقم باظافة عنصر Combobox في اول خلية للقائمة المنسدلة G3 3) ضع هدا الكود في حدث شيت صفحة الادخال Dim F(), MH, Rng Private Sub ComboBox1_Change() Dim MH() MH = Application.Transpose([liste]) Me.ComboBox1.List = MH If Me.ComboBox1.ListIndex = -1 And IsError(Application.Match(Me.ComboBox1, MH, 0)) Then Me.ComboBox1.List = Filter(MH, Me.ComboBox1.Text, True, vbTextCompare) Me.ComboBox1.DropDown End If ActiveCell.Value = Me.ComboBox1 If ComboBox1.Value <> "" Then ComboBox1.BackColor = RGB(255, 255, 255) Else ComboBox1.BackColor = &HFFFF00 End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim lr As Long Dim sh1 As Worksheet: Set sh1 = Worksheets("صفحة الادخال") Dim sh2 As Worksheet: Set sh2 = Worksheets("التعريف") lr = sh1.Range("A" & Rows.Count).End(xlUp).Row Set wsdata = Range("G3:G" & lr) If Not Intersect(wsdata, Target) Is Nothing And Target.Count = 1 Then If MH <> "" Then If IsError(Application.Match(Range(MH), F, 0)) Then Range(MH) = "" F = Application.Transpose(sh2.Range("Liste")) Me.ComboBox1.Height = Target.Height + 4 Me.ComboBox1.Width = Target.Width Me.ComboBox1.Top = Target.Top Me.ComboBox1.Left = Target.Left Me.ComboBox1 = Target Me.ComboBox1.Visible = True Me.ComboBox1.Activate MH = Target.Address Else Me.ComboBox1.Visible = False End If End Sub Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Set Rng = ActiveCell If KeyCode = 13 Then If IsError(Application.Match(Rng, F, 0)) Then Rng = "" Rng.Offset(1).Select End If End Sub Private Sub ComboBox1_DropButtonClick() lr = Worksheets("التعريف").Cells(Rows.Count, 5).End(xlUp).Row ComboBox1.List = Sheet2.Range("E2:E" & lr).Value End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If Not iGblInhibitTextBoxEvents Then ComboBox1.Value = "" End If End Sub 3) دوبل كليك على combobox وابحث باي حرف في اي مكان في السطر . حركة الصندوق.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاستاد @محمد حسن المحمد Private Sub Workbook_Open() MyPassword = ("123") For Each Worksheet In ActiveWorkbook.Worksheets Worksheet.protect Password:=MyPassword, DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True Next End Sub ما الخطأ في هذا الكود.xlsm

بارك الله فيك اخي نظيم =IF(C2="";"0";C2-SUM(C3:C7)-SUM(C9:C11)) التجربة 1 (1) (1).xlsx