نجوم المشاركات

عليكم السلام ورحمة الله وبركاته يمكنك وضع اسماء الفصول في الصف 11 ووضع هذه المعادلة في الخلية D12 =IFERROR(COUNTIF(OFFSET(أساسية!$A$1,MATCH($C12,أساسية!$B$1:$B$100,0)-1,0,1,50),D$11),"") ويمكنك سحبها يسارا لتجلب أعداد باقيد الفصول وسحبها لأسفل لباقي المعلمين بالتوفيق

وعليكم السلام ورحمة الله تعالى وبركاته بعد معاينة الملف لاحظت انك ترغب بحدف الخلايا الفارغة مع البقاء على البيانات بمكانها الاصلي مع مراعات عدم التاثير على الاعمدة المجاورة لانها ربما تحتوي على معادلات جرب هدا Sub Supp_lignes_VidesArray() Dim n&, i&, j&, k&, Irow& Dim a As Variant, arr As Variant Dim f As Worksheet: Set f = Sheets("Sheet1") Irow = f.Columns("B:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If Irow < 4 Then Exit Sub a = f.Range("B4:E" & Irow).Value For i = 1 To UBound(a, 1) If a(i, 1) <> "" And a(i, 2) <> "" And a(i, 3) <> "" And a(i, 4) <> "" Then n = n + 1 End If Next i If n = 0 Then Exit Sub Application.ScreenUpdating = False ReDim arr(1 To n, 1 To UBound(a, 2)) j = 0 For i = 1 To UBound(a, 1) If a(i, 1) <> "" And a(i, 2) <> "" And a(i, 3) <> "" And a(i, 4) <> "" Then j = j + 1 For k = 1 To UBound(a, 2) arr(j, k) = a(i, k) Next k End If Next i f.Range("B4:E" & Irow).ClearContents f.Range("B4").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr Application.ScreenUpdating = True End Sub وهدا في حالة كانت البيانات على الاعمدة B-C-D-E تحتوي على صيغ يجب الاحتفاظ بها عند التخلص من الخلايا الفارغة Sub Supp_lignes_Returns_formulas() Dim n&, i&, j&, k&, Irow& Dim a As Variant, arr As Variant Dim f As Worksheet: Set f = Sheets("Sheet1") Irow = f.Columns("B:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If Irow < 4 Then Exit Sub a = f.Range("B4:E" & Irow).Value For i = 1 To UBound(a, 1) If a(i, 1) <> "" And a(i, 2) <> "" And a(i, 3) <> "" And a(i, 4) <> "" Then n = n + 1 End If Next i If n = 0 Then Exit Sub ReDim arr(1 To n, 1 To UBound(a, 2)) Application.ScreenUpdating = False j = 0 For i = 1 To UBound(a, 1) If a(i, 1) <> "" And a(i, 2) <> "" And a(i, 3) <> "" And a(i, 4) <> "" Then j = j + 1 For k = 1 To UBound(a, 2) If f.Cells(i + 3, k + 1).HasFormula Then arr(j, k) = f.Cells(i + 3, k + 1).Formula Else arr(j, k) = f.Cells(i + 3, k + 1).Value End If Next k End If Next i f.Range("B4:E" & Irow).ClearContents f.Range("B4").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr Application.ScreenUpdating = True End Sub New Microsoft Excel Worksheet v2.xlsb

عليكم السلام ورحمة الله وبركاته يمكنك تجربة هذا الكود Sub MoveDataWithoutDeletingRows() Dim ws As Worksheet Dim lastRow As Long Dim i As Long, startRow As Long Set ws = ThisWorkbook.Sheets("Sheet1") ' قم بتغيير اسم الورقة حسب الحاجة lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row startRow = 1 ' يمكنك تغيير قيمة startRow حسب الحاجة For i = startRow To lastRow If Application.WorksheetFunction.CountA(ws.Range("A" & i & ":E" & i)) > 0 Then If i <> startRow Then ws.Range("A" & i & ":E" & i).Copy Destination:=ws.Range("A" & startRow & ":E" & startRow) End If startRow = startRow + 1 End If Next i ' مسح البيانات من الصفوف الأصلية دون حذف الصفوف ws.Range("A" & startRow & ":E" & lastRow).ClearContents End Sub بالتوفيق

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا ربما يناسبك Module Sub ProtectWS() Dim sh As Variant, MyArray As Variant, Password As String Password = "1234" MyArray = Array(Sheet1, Sheet2) ' <<=== ' اسماء الاوراق المرغوب حمايتها For Each sh In MyArray sh.Protect Password, UserInterfaceOnly:=True, AllowFiltering:=True Next sh End Sub ThisWorkbook Private Sub Workbook_Open() ProtectWS End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) ProtectWS End Sub وفي حدث الاوراق المحددة Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Password As String Dim Clé As String Password = "1234" ' الباسوورد الخاص بك If Me.ProtectContents Then Clé = InputBox(" الورقة محمية يرجى إدخال كلمة المرور") If Clé = Password Then Me.Unprotect Password Else MsgBox "كلمة المرور غير صحيحة", vbCritical Exit Sub End If End If End Sub ' في جالة الرغبة بنسخ البيانات من ورقة لاخرى يمكنك تعطيل الكود التالي Private Sub Worksheet_Deactivate() Dim Password As String Password = "1234" Me.Protect Password End Sub test.xlsb

السلام عليكم المرفق هو البحث بكلمة داخل جمله ولكن يوجد مشكلة في ظهور الرسالة محتاج مساعدة في عدم ظهور الرسالة المرفقة في نتيجة الاستلام وان يكون نتيجة #ERROR هي (عدم وجود المطلوب) re.accdb

تفضل بالتوفيق DoCmd.SetWarnings False 'On Error GoTo errhld: Dim Arr() As String Dim i As Long Arr = Split(Str) FnSearch = "عدم وجود المطلوب" ' القيمة الافتراضية إذا لم يتم العثور على شيء For i = 0 To UBound(Arr) If i + 8 <= UBound(Arr) Then If Nz(DLookup("LikeA", "KindX", "LikeA='" & Trim(Arr(i)) & " " & Trim(Arr(i + 1)) & " " & Trim(Arr(i + 2)) & " " & Trim(Arr(i + 3)) & " " & Trim(Arr(i + 4)) & " " & Trim(Arr(i + 5)) & " " & Trim(Arr(i + 6)) & " " & Trim(Arr(i + 7)) & " " & Trim(Arr(i + 8)) & "'"), 0) <> 0 Then FnSearch = DLookup("LikeB", "KindX", "LikeA='" & Trim(Arr(i)) & " " & Trim(Arr(i + 1)) & " " & Trim(Arr(i + 2)) & " " & Trim(Arr(i + 3)) & " " & Trim(Arr(i + 4)) & "'") Exit For End If End If If i + 3 <= UBound(Arr) Then If Nz(DLookup("LikeA", "KindX", "LikeA='" & Trim(Arr(i)) & " " & Trim(Arr(i + 1)) & " " & Trim(Arr(i + 2)) & " " & Trim(Arr(i + 3)) & "'"), 0) <> 0 Then FnSearch = DLookup("LikeB", "KindX", "LikeA='" & Trim(Arr(i)) & " " & Trim(Arr(i + 1)) & " " & Trim(Arr(i + 2)) & " " & Trim(Arr(i + 3)) & "'") Exit For End If End If If i + 2 <= UBound(Arr) Then If Nz(DLookup("LikeA", "KindX", "LikeA='" & Trim(Arr(i)) & " " & Trim(Arr(i + 1)) & " " & Trim(Arr(i + 2)) & "'"), 0) <> 0 Then FnSearch = DLookup("LikeB", "KindX", "LikeA='" & Trim(Arr(i)) & " " & Trim(Arr(i + 1)) & " " & Trim(Arr(i + 2)) & "'") Exit For End If End If If i + 1 <= UBound(Arr) Then If Nz(DLookup("LikeA", "KindX", "LikeA='" & Trim(Arr(i)) & " " & Trim(Arr(i + 1)) & "'"), 0) <> 0 Then FnSearch = DLookup("LikeB", "KindX", "LikeA='" & Trim(Arr(i)) & " " & Trim(Arr(i + 1)) & "'") Exit For End If End If If i <= UBound(Arr) Then If Nz(DLookup("LikeA", "KindX", "LikeA='" & Trim(Arr(i)) & "'"), 0) <> 0 Then FnSearch = DLookup("LikeB", "KindX", "LikeA='" & Trim(Arr(i)) & "'") Exit For End If End If Next i errhld = Nz(DLookup("KindX", "TableX", "[NameX] Like '" & SetName & "'"), "غير مسجل")

جزاكم الله خيرا الأخ أ / محمد صالح والأخ محمد هشام الأكواد جميله وتفي بالغرض شكرا لكم

بارك الله فيك اخي @عبدالله بشير عبدالله نعم يمكننا إظافة شروط أخرى بطريقة مختصرة وبدون تقييد للمعايير فقط يكفي الإشارة على عناوين خلايا تنفيد الكود مع تعديل طريقة الفلترة لنتمكن من التحقق من وجود بيانات مطابقة قبل الانتقال لورقة لوحة المعلومات وفلترة البيانات Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rCrit As String, Lr As Long Dim OneRng As Variant, i As Long, cnt As Boolean Dim f As Worksheet: Set f = Sheets("الرئيسية") If Not Intersect(Target, Me.Range("B17, C17, D17, E17, F17, G17")) Is Nothing Then rCrit = Target.Value If rCrit = "" Then Exit Sub If f.AutoFilterMode Then f.AutoFilterMode = False Lr = f.Cells(f.Rows.count, "J").End(xlUp).Row OneRng = f.Range("J2:J" & Lr).Value For i = 1 To UBound(OneRng, 1) If OneRng(i, 1) = rCrit Then: cnt = True: Exit For Next i If cnt Then f.Activate With f.Range("B2:L" & Lr) .AutoFilter 9, rCrit End With Application.Goto f.Range("J2") Else MsgBox "قاعدة البيانات لا تتضمن معاملات من نوع " & rCrit, vbInformation, "نتيجة الفلترة" End If End If End Sub كما يمكننا كدالك استخدام مصفوفة (Array) لتحديد مجموعة من الخلايا بدلاً من تحديدها بشكل مباشر Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rCrit As String, Lr As Long, n As Boolean, ColArray As Variant Dim OneRng As Variant, i As Long, cnt As Boolean Dim f As Worksheet: Set f = Sheets("الرئيسية") ColArray = Array("B17", "C17", "D17", "E17", "F17", "G17") For i = LBound(ColArray) To UBound(ColArray) If Not Intersect(Target, Me.Range(ColArray(i))) Is Nothing Then n = True Exit For End If Next i If n Then rCrit = Target.Value If rCrit = "" Then Exit Sub If f.AutoFilterMode Then f.AutoFilterMode = False Lr = f.Cells(f.Rows.count, "J").End(xlUp).Row OneRng = f.Range("J2:J" & Lr).Value For i = 1 To UBound(OneRng, 1) If OneRng(i, 1) = rCrit Then: cnt = True: Exit For Next i If cnt Then f.Activate With f.Range("B2:L" & Lr) .AutoFilter 9, rCrit End With Application.Goto f.Range("J2") Else MsgBox "قاعدة البيانات لا تتضمن معاملات من نوع " & rCrit, vbInformation, "نتيجة الفلترة" End If End If End Sub ملف ادارة طلبات.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بعد اذن استاذنا الفاضل محمد هشام ,حل لكل الخيارات وان لم يطلبها صاحب الموضوع الكود Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim wsDashboard As Worksheet Dim wsMain As Worksheet Dim rng As Range Dim count As Long Dim filterValue As String Set wsDashboard = ThisWorkbook.Sheets("لوحة المعلومات") Set wsMain = ThisWorkbook.Sheets("الرئيسية") Select Case Target.Address Case wsDashboard.Range("C17").Address filterValue = "تحت الاجراء" Case wsDashboard.Range("D17").Address filterValue = "في الانتظار" Case wsDashboard.Range("F17").Address filterValue = "مكتمل" Case wsDashboard.Range("G17").Address filterValue = "محالة" Case wsDashboard.Range("H17").Address filterValue = "معلق / مؤجل" Case Else Exit Sub End Select wsMain.Activate If wsMain.AutoFilterMode Then wsMain.AutoFilterMode = False End If wsMain.Range("A1").AutoFilter Field:=10, Criteria1:=filterValue Set rng = wsMain.Range("J2:J" & wsMain.Cells(wsMain.Rows.count, "J").End(xlUp).Row) count = Application.WorksheetFunction.CountIf(rng, filterValue) If count > 0 Then MsgBox "عدد الطلبات التي تحتوي على '" & filterValue & "' هو: " & count Else MsgBox "لا توجد طلبات تحتوي على '" & filterValue & "'." End If End Sub الملف ملف ادارة طلبات1.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim WS As Worksheet, f As Worksheet Dim r As Range, DataRng As Range If Not Intersect(Target, Me.Range("C17")) Is Nothing Then Set WS = Sheets("الرئيسية") Set f = Sheets("لوحة المعلومات") WS.Activate If WS.AutoFilterMode Then WS.AutoFilterMode = False End If Set DataRng = WS.Range("A1").CurrentRegion With DataRng .AutoFilter Field:=10, Criteria1:="تحت الاجراء" End With On Error Resume Next Set r = WS.Range("J:J").SpecialCells(xlCellTypeVisible) On Error GoTo 0 If r Is Nothing Then MsgBox "لم يتم العثور على أي صفوف تحتوي على تحت الاجراء", vbInformation WS.AutoFilterMode = False End If Application.Goto WS.Range("J3") End If End Sub

منذ فترة كنت عملت هذا المخطط الذي يبسط فهم عمل العلاقات بين الجداول المتسلسلة .. 🙂

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

مشاركة مع اخي ازهر انظر هنا في هذه المشاركة .. طريقة اخرى لتحقيق الفكرة

راجعت المرفق وجدته يسجل تاريخ ووقت الدخول في جدول المستخدمين .. ويتم تحديثه في كل مرة يتم الدخول .. اذا تريد الدخول والخروج وحفظه كبيانات تاريخية يكفي ان تضيف جدول واحد يشتمل على : رقم المستخدم / اسمه / نوع الحركة ( in - out ) / تاريخ ووقت الحركة بمعنى ان الدخول والخروج في حقل واحد الذي يفرق بينهما هو نوع الحركة ... لماذا ؟ من اجل مرونة البيانات فقد يدخل المستخدم ويخرج اكثر من مرة في اليوم ملحوظة : الافضل استبدال الماكرو بكود داخل المحرر

Private Sub Manul_AfterUpdate() If IsNull(Me.Manul.Value) Or Me.Manul.Value = "" Then Me.Manul.BackColor = RGB(255, 255, 255) Else Me.Manul.BackColor = RGB(255, 255, 0) End If End Sub

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