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

طيب جرب واعلمنا بالنتيجة ..... استخدم هذا الامر تحت زر تفريغ على الجدول ..... Dim strField As String Dim regex As Object Dim matches As Object Dim match As Variant Dim cleanedValue As String Dim FullText As String Dim FirstPhrase, SecondPhrase As String Dim RemainingText As String Set regex = CreateObject("VBScript.RegExp") regex.Global = True regex.IgnoreCase = True strField = Me.a regex.Pattern = "الوزن:\d+|\d+\s*\$\s*اجار شاحنة|\d+\s*\$\s*عمال|\d+\s*\$\s*رسوم|\d+\s*\$\s*وصل|\d+\s*\$\s*خدمات|العدد:\d+" Set matches = regex.Execute(strField) FirstPhrase = Split(strField, "المادة")(0) SecondPhrase = Split(strField, "العدد")(0) RemainingText = Replace(SecondPhrase, FirstPhrase & "المادة", "") FirstPhrase = Replace(FirstPhrase, "السيد", "") DoCmd.OpenForm "Test1", , , , acFormAdd Forms!Test1.Form.Recordset.AddNew For Each match In matches cleanedValue = Replace(match.Value, "$", "") cleanedValue = Replace(cleanedValue, "الوزن:", "") cleanedValue = Replace(cleanedValue, "رسوم", "") cleanedValue = Replace(cleanedValue, "وصل", "") cleanedValue = Replace(cleanedValue, "خدمات", "") cleanedValue = Replace(cleanedValue, "عمال", "") cleanedValue = Replace(cleanedValue, "اجار شاحنة", "") cleanedValue = Replace(cleanedValue, "العدد:", "") cleanedValue = Trim(cleanedValue) If InStr(match.Value, "الوزن:") > 0 Then Forms![Test1]![d].Value = cleanedValue ElseIf InStr(match.Value, "عمال") > 0 Then Forms![Test1]![g].Value = cleanedValue ElseIf InStr(match.Value, "وصل") > 0 Then Forms![Test1]![e].Value = cleanedValue ElseIf InStr(match.Value, "خدمات") > 0 Then Forms![Test1]![f].Value = cleanedValue ElseIf InStr(match.Value, "اجار شاحنة") > 0 Then Forms![Test1]![h].Value = cleanedValue ElseIf InStr(match.Value, "العدد:") > 0 Then Forms![Test1]![c].Value = cleanedValue End If Next match Forms![Test1]![a].Value = FirstPhrase Forms![Test1]![b].Value = RemainingText

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن اخونا الفاضل @عبدالله بشير عبدالله واثراءا للموضوع 1) تم تنفيد طلبك مع اظافة امكانية البحث على الملف عن طريق الإستعلام أو بالحروف الأولى عند تفعيل البحث التلقائي CheckBox1 2) بالنسبة لإنشاء الأوراق على نفس الملف أو مصنف جديد تمت مراعات نسخ البيانات بنفس التنسيق والترتيب 3) تفعيل خاصية البحث مع وجود حماية على ورقة الرئيسية الباسوورد 1234 أكواد البحث من خلال Textbox1 Public WS As Worksheet Public Const WsPasse As String = "1234" Sub Recherche() ' بحث بالإستعلام Dim OneRng As Range, c As Range Dim Clé As String, r As String, lastRow As Long Set WS = ThisWorkbook.Sheets("Main") WS.Unprotect Password:=WsPasse lastRow = WS.Columns("A:L").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Clé = Trim(WS.Range("B1").Value) WS.OLEObjects("CheckBox1").Object.Value = False Application.ScreenUpdating = False Set OneRng = WS.Range("A3:L" & lastRow) OneRng.Interior.ColorIndex = xlNone If Clé = "" Then MsgBox "الرجاء إدخال قيمة البحث", vbExclamation Application.ScreenUpdating = True WS.Protect Password:=WsPasse Exit Sub End If Set c = OneRng.Find(What:=Clé, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False) If Not c Is Nothing Then r = c.Address Do c.Interior.Color = RGB(255, 0, 0) Set c = OneRng.FindNext(c) Loop While Not c Is Nothing And c.Address <> r Else MsgBox "لم يتم العثور على أي نتائج", vbInformation End If WS.Protect Password:=WsPasse Application.ScreenUpdating = True End Sub '================================================== Sub Search_by_first_letters() 'بحث تلقائي Dim OneRng As Range Dim Clé As String, tmp As Variant Dim i&, j&, lastRow&, b As String Set WS = ThisWorkbook.Sheets("Main") WS.Unprotect Password:=WsPasse lastRow = WS.Columns("A:L").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set OneRng = WS.Range("A3:L" & lastRow) tmp = OneRng.Value Clé = Trim(WS.Range("B1").Value) OneRng.Interior.ColorIndex = xlNone If Clé = "" Then WS.Protect Password:=WsPasse Exit Sub End If Application.ScreenUpdating = False For i = 1 To UBound(tmp, 1) For j = 1 To UBound(tmp, 2) If Not IsEmpty(tmp(i, j)) Then b = Trim(CStr(tmp(i, j))) If Left(b, Len(Clé)) = Clé Then WS.Cells(i + 2, j).Interior.Color = RGB(255, 0, 0) End If End If Next j Next i Application.ScreenUpdating = True WS.Protect Password:=WsPasse End Sub الموظفين.xlsb

وعليكم السلام ورحمة الله وبركاته الزر الاخير الحذف ملغي لان الز رين انشاء صفحة وزر فصل المرتب يقومان بحذف الصفحات قبل انشائها في كل ضغظة على الزر && الاستعلام باي كلمة من الجدول وعند الضغظ على زراستغلام ينقلك الى الكلمة التي تبحث عنها مع تلوينها وتكون كتابة كلمة البحث في الخلية B1 الموظفين.xlsb

إذا وجدت صعوبة في تطبيق هذا القناع على الخلية ولم يلبي إحتياجك فممكن تعمل حيلة أخرى بعمل 4 حقول منفصلة بحيث أن كل حقل يحمل جزئية من الترميز وبالكود يمكن تخلي المؤشر ينتقل للحقل التالي ، وممكن تعمل حقل محسوب يجمع بيانات الحقول الأربعة في حقل واحد 🙂

بارك الله فيك اخي @عبدالله بشير عبدالله نعم يمكننا إظافة شروط أخرى بطريقة مختصرة وبدون تقييد للمعايير فقط يكفي الإشارة على عناوين خلايا تنفيد الكود مع تعديل طريقة الفلترة لنتمكن من التحقق من وجود بيانات مطابقة قبل الانتقال لورقة لوحة المعلومات وفلترة البيانات 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 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

طيب ... الحمدلله رب العالمين

اقصد هذه المسميات والعلامات ...

طيب ... بارك الله فيك ... هل دائما تنسيق الرسالة بالطريقة الموجودة في المرفق

المسألة فقط تتلخص في العرض نستخدم التنسيق عند العرض حسب الحاجة .. نعرض وقت فقط او تاريخ فقط عند الطباعة سيظهر لنا التنسيق فقط .. ولكن جرب التركيز على الحقل في الجدول سيظهر لك التاريخ والوقت الكامل الافضل ان يبقى التاريخ جنرال دائما baset3.rar

وعليكم السلام ورحمة الله وبركاته انشأ وحدة نمطية وضع التالي بها :::: Public Sub CheckEntryLanguage(TB As TextBox, Txt As String) If InStr("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz", Txt) > 0 Then TB.KeyboardLanguage = 3 MsgBox "يحب ان تكتب بالعربي .. مع العلم أنه تم تغيير اللغة للوحة المفاتيح." TB = "" End If End Sub وفي حدث عند التغيير في مربع النص ضع هذا ::::: If TxtBox.Text = "" Then Exit Sub Call CheckEntryLanguage(Me.TxtBox, Right(TxtBox.Text, 1))

بالنسبة لهده النقطة قد تم تعديلها لدمج بيانات مثلا السابعة و السابعة مهندسين في ورقة واحدة اما بخصوص البحث اظن انك بحاجة لتغيير طريقة البحث لتتمكن من فرز البيانات بجزء من قيمة البحث على جميع الأعمدة انصحك باستخدام نمودج مستخدم (يوزرفورم) سيوفر لك سرعة جلب البيانات خاصة ان ملفك الاصلي يتضمن ما يقارب 10 الف موظف الموظفين 2.xlsb

= ActiveSheet

تفضل مع اني اتحاشى استخدام الماكرو في اعمالي ، لذا راعيت ان ابقي على التصميم الذي انت عملته ستلاحظ اين وظفت اكوادي baset2.rar

السلام عليكم جهد مشكور جدا لكم هل يمكن اضافه action لجعل ال list تنكمش لتظهر الايقونات فقط او تتمدد لتتظهر الايقونه بجوارها الاسم و كيف يمكن التحكم بالوان الخلفيه و الازرار و الاكشن عند الضغط علي زر كا الوان في المثال السابق وشكرا

تفضل بالتوفيق 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 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

يعني تريد نقل هذه البيانات مجزئة للحقول الظاهرة في النموذج الاخر ... صحيح هذه المطلوب ؟؟

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا ربما يناسبك 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