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

وعليكم السلام 1. بوجه عام ، اي وقت تحصل على خطأ OLE Server ، قم باعادة تضبيطات لغة دعم حروف Unicode (اي لغة غير الانجليزية) للحاسبة ، حسب اللغة التي تستعملها في برنامج الاكسس (في حالتي هي اللغة العربية) . 2. سابقا في الاكسس 2003 وما قبل ، كانت هناك بعض الاوامر التي تعمل بطريقة صحيحة ، ولكنها لا تعمل في الاكسس 2007 وما بعد ، ومنها مكتبات نواة 32بت على الاكسس نواة 64بت. 3. الطريقة الصحيحة للتعامل مع جميع اخطاء الاكسس في الكود ، في اعلا كل صفحة دائما استعمل : Option Compare Database Option Explicit . والسطر الثاني جدا مهم للمبرمج ، بحيث يخبرك الاكسس اماكن الخطأ في الكود ، تلقائيا عند كتابة السطر ، او عن طريق امر Compile : واجعل الاكسس يكتب هذا السطر تلقائيا في كل صفحة كود ، هكذا : و . اما امر Compile : . وانا استعمل الامر بعد كل تحديث لأسطر الكود وقبل تجربة تشغيل البرنامج/النموذج (مو اقل من 5-20 مرة في اليوم لكل تحديث) ، ومن كثرة استعمالي له ، وضعت الزر خارج القائمة ، هكذا: . اعمل Compile ، وسيخبرك الاكسس مكان الخطأ ، هكذا : . وهنا نستطيع مساعدتك ، فتخبرنا اسم الخطأ ، ومكانه. 4. الاكسس مرتبط ارتباط وثيق بالوندوز ، وهناك الكثير من تحديثات الوندوز اللي تعمل مشكلة في الاكسس ، لذا : أ. النصيحة الذهبية ، لا تشترك في Preview Updates ، ولا تنزل التحديثات حين اصدارها من مايكروسوفت ، ب. اما اذا سبق السيف العدل ، وتم عمل تحديثات الوندوز ، وظهرت لك اخطاء في برنامجك ، فهناك حلين : البحث في الانترنت لحل ، ولا تنسى ان هناك مجتمع كبير جدا للاكسس ، وكما حصلت لك المشكلة ، فستكون حصلت لآخرين ، وتم التحدث عنها ، وغالبا يتم تقديم طريقة معالجة المشكلة ، آخر الدواء الكي ، ولما تستصعب عليك الامور ، وخصوصا اذا كان لديك برنامج يتم استعماله في امكان عديدة (ولا يمكنك الوصول اليها) ، فيمكنك التراجع عن تحديث الوندوز ، واما اذا قدرت تصبر شوي (والله اعلم طول هذه الفترة) ، فدائما يتم ايصال خبر هذه المشاكل الى شركة مايكروسوفت ، وتقوم : 1. إما بعمل تحديث وندوز جديد لحل هذه المشكلة ، 2. او ترسل تحديث/تعديل الى الاكسس الموجود على حاسبتك مباشرة وبدون علمك

وعليكم السلام ورحمة الله تعالى وبركاته بعد إدن أستادنا الفاضل @Foksh جرب إفراغ اليوزرفورم من جميع الأكواد السابقة ولصق الكود التالي ربما يناسبك Private Sub UserForm_Initialize() ComboBox1.Clear: Dim sh As Worksheet For Each sh In ThisWorkbook.Sheets: ComboBox1.AddItem sh.Name: Next ListBox1.ColumnCount = 3: ListBox1.ColumnWidths = "70;70;200" End Sub Private Sub ListBox1_Click() If ListBox1.ListIndex = -1 Then Exit Sub Dim ShName As String, Addr As String ShName = ListBox1.List(ListBox1.ListIndex, 0) Addr = ListBox1.List(ListBox1.ListIndex, 1) Sheets(ShName).Activate Sheets(ShName).Range("A4:F" & Sheets(ShName).Rows.Count).Interior.ColorIndex = xlNone With Sheets(ShName).Range("A" & Range(Addr).Row & ":F" & Range(Addr).Row) .Interior.Color = vbCyan: .Cells(1, 1).Activate End With TextBox2.Value = ListBox1.List(ListBox1.ListIndex, 2) End Sub Private Sub TextBox1_Change() On Error GoTo Cleanup SetApp False Dim ws As Worksheet, Sh_Name As String, ky As String, LastRow As Long, LastCol As Long Dim OnRng As Variant, i As Long, j As Long, xCount As Long, CellAddress As String Sh_Name = ComboBox1.Value ky = Trim(TextBox1.Text) If Sh_Name = "" Or ky = "" Then ListBox1.Clear Label5.Caption = "عدد النتائج: 0" If Sh_Name <> "" Then Sheets(Sh_Name).Range("A4:F" & _ Sheets(Sh_Name).Rows.Count).Interior.ColorIndex = xlNone Me.TextBox2 = "" GoTo Cleanup End If Set ws = Sheets(Sh_Name) With ws LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row LastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column End With ListBox1.Clear ws.Range("A4:F" & ws.Rows.Count).Interior.ColorIndex = xlNone xCount = 0 OnRng = ws.Range(ws.Cells(4, 1), ws.Cells(LastRow, LastCol)).Value For i = 1 To UBound(OnRng, 1) For j = 1 To UBound(OnRng, 2) If InStr(1, OnRng(i, j), ky, vbTextCompare) > 0 Then xCount = xCount + 1 CellAddress = ws.Cells(i + 3, j).Address(False, False) ListBox1.AddItem Sh_Name ListBox1.List(ListBox1.ListCount - 1, 1) = CellAddress ListBox1.List(ListBox1.ListCount - 1, 2) = OnRng(i, j) ws.Range("A" & (i + 3) & ":F" & (i + 3)).Interior.Color = vbCyan Exit For End If Next j Next i Label5.Caption = "عدد النتائج: " & xCount Cleanup: SetApp True End Sub Private Sub UserForm_Terminate() Dim sh As Worksheet For Each sh In ThisWorkbook.Sheets sh.Range("A4:F" & sh.Rows.Count).Interior.ColorIndex = xlNone Next End Sub Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = "": ListBox1.Clear End Sub Private Sub ComboBox1_Change() On Error Resume Next If ComboBox1.ListIndex = -1 Then Exit Sub TextBox1 = "": ListBox1.Clear Dim sh As Worksheet For Each sh In ThisWorkbook.Sheets sh.Range("A4:F" & sh.Rows.Count).Interior.ColorIndex = xlNone Next Sheets(ComboBox1.Value).Activate End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub ملاحظة :تم الاستغناء عن الكود Search_In_Sh() فأنت الآن لست بحاجة إليه بحث في عدة أوراق مع التحديد v2.xlsm

أخي @Hesham.Abusna نرجو منك التكرم بإرفاق نسخة من الملف الذي واجهت فيه المشكلة هدا سيساعدنا ذلك كثيرا على فحص هيكل الملف و المعادلات المستخدمة ولربما حجم البيانات ومن ثم تقديم الحل الأمثل بإذن الله كما يجب الإنتباه أنه في بعض الحالات قد يتسبب حجم المعادلات الكبير أو وجود أكواد معقدة أو حتى أوراق فارغة أو مخفية في اختلاف سلوك الكود لذلك فالمعاينة المباشرة ضرورية لتقديم دعم دقيق ومناسب و تشخيص المشكلة بدقة والوقوف على السبب الفعلي على العموم جرب الكود التالي على ملفك الأصلي ووافينا بالنتيجة Option Explicit Sub Sauvegarde_WB() Dim dossier$, chemin$, sFichier$, sPath$, sNom$ Dim WS As Worksheet, newWB As Workbook, newWs As Worksheet Dim n As Integer, data As Variant, OnRng As Range, _ shp As Shape, col As Long, rw As Long On Error GoTo EndClear SetApp False Set newWB = Workbooks.Add(xlWBATWorksheet) newWB.Sheets(1).Name = "Temp" n = 1 For Each WS In ThisWorkbook.Worksheets Set newWs = newWB.Sheets.Add(After:=newWB.Sheets(newWB.Sheets.Count)) sNom = Left(WS.Name, 31) Do While f(sNom, newWB) sNom = Left(WS.Name, 28) & "_" & n: n = n + 1 Loop newWs.Name = sNom Set OnRng = WS.UsedRange If OnRng.Cells.Count > 1 Then data = OnRng.Value newWs.Range("A1").Resize(UBound(data, 1), UBound(data, 2)).Value = data OnRng.Copy newWs.Range("A1").PasteSpecial xlPasteFormats Application.CutCopyMode = False For col = 1 To OnRng.Columns.Count newWs.Columns(col).ColumnWidth = WS.Columns(col).ColumnWidth Next col For rw = 1 To OnRng.Rows.Count newWs.Rows(rw).RowHeight = WS.Rows(rw).RowHeight Next rw Application.Goto newWs.Range("A1"), True End If On Error Resume Next For Each shp In newWs.Shapes If shp.Type = msoFormControl Or shp.Type = msoOLEControlObject Then shp.Delete Next shp On Error GoTo EndClear Next WS newWB.Sheets("Temp").Delete dossier = ThisWorkbook.Path & "\Workbook_Copy" If Dir(dossier, vbDirectory) = "" Then MkDir dossier sPath = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) sFichier = sPath & "_" & Format(Now, "dd-mm-yyyy_hh-nn-ss") & ".xlsx" chemin = dossier & "\" & sFichier newWB.Sheets(1).Activate newWB.SaveAs Filename:=chemin, FileFormat:=xlOpenXMLWorkbook newWB.Close False MsgBox "تم نسخ الملفات بنجاح", vbInformation SetApp True Exit Sub EndClear: SetApp True End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub Private Function f(sheetName As String, wb As Workbook) As Boolean Dim sht As Worksheet For Each sht In wb.Sheets If sht.Name = sheetName Then f = True: Exit Function Next sht f = False End Function إليك المرفق مرة أخرى بعد إظافة بعض المعادلات الجديدة للتجربة TEST v2.rar

وهذا من احد الأسباب التي دفعتني لعمل هذه السلسلة بالتوفيق إن شاء الله

أخواني وأساتذتي ومعلمينا ( دون استثناء ) الكثير من المواضيع التي قد تكون تطرقت الى هذا الموضوع ولكن بطرق وأشكال مختلفة . اليوم وفقط في أوفيسنا / آكسيس ، سأقدم لكم نظام كامل متكامل لإدارة الطابور والدور الذي يمكن استخدامه في أي منشئة تجارية تتعامل بهذا النظام . من المعروف أننا عندما ندخل مركز للصرافة على سبيل المثال ، فإن العميل يحصل على رقم دور مطبوع على شكل تذكرة يحتفظ بها لحين تفرغ موظف لتلبية طلبه وخدمته . وعند انتظارك كعميل لحين وصول الدور لك فإنك تراقب شاشة الدور لمعرفة أين وصل الدور لأي تذكرة . وطبعاً ما يميز هذا النظام أنك في حين لم تكن متابعاً لشاشة العرض فإن النظام الصوتي كفيل بتنبيهك أين وصل الدور ولأي شباك موظف . إلى هنا وكل هذا متاح لك اليوم مع نظام مراقبة الطابور والدور الجديد . وسنسير بشرح المكونات تسلسلاً وشرحاً وافياً ( دون الإطالة .. ) أولاً :- واجهة حجز الدور الذي سيبدأ منها العميل بأخذ دور له ، وهي ذات واجهة بسيطة فقط زر واحد ينقره العميل للحصول على رقم دوره . مرفق تالياً صورة الواجهة ، والتي تدعم بالطبع شاشة اللمس . أي أن ما على العميل فقط هو النقر على الزر "احصل على رقم دور جديد" . ثانياً :- وبعد أن حصل العميل على دوره ، سيراقب دوره في قاعة الإنتظار على شاشة عرض الأدور ، والتي بدورها ستخبر العميل الى أي شباك موظف عليه التوجه حين يحين دوره ، وطبعاً لإرضاء الرغبات قمت بإضافة ميزة الناطق الصوتي ( عربي - انجليزي "اللغة الإفتراضية" ) . أي أنه عليك - كمستخدم أو مصمم - لاحقاً تفعيل اللغة العربية الصوتية (Text-to-speech) . وهنا نقطة مهمة يجب أن نمر عليها سريعاً كي تتوضح لك عزيزي القارئ كيف يمكن تفعيل القارئ الصوتي العربي للنصوص . لذا هذا الفيديو يوضح الخطوات الأولى لإضافة اللغة العربية الصوتية إلى ويندوز 10 . النقطة المزعجة من مايكروسوفت أنه وللأسف لا يتم فعلاً إضافة هذه التثبيتات الى مكانها الصحيح في محرر الريجستري . لذا علينا فعل ذلك بالطريقة اليدوية لضمان تشغيل القارئ الصوتي العربي . لذا ولمحة سريعة سنتطرق للموضوع بشكل مختصر :- بعد الذهاب إلى محرر الريجستري + R اكتب كلمة regedit اذهب الى المسار التالي : Computer\HKEY_LOCAL_MACHINE\SOFTWARE\WOW6432Node\Microsoft\Speech_OneCore\Voices\Tokens قم بتصدير هذا المفتاح كاملاً الى سطح المكتب بأي اسم تريده . افتح ملف الريجستري هذا باستخدام المفكرة Notepad . قم بإزالة الجزء "_OneCore" من جميع المسارات الموجودة أمامك . احفظ الملف ، وافتحه واختر Yes - نعم من الرسالة التي ستظهر لك مرتين ( على ما أعتقد ) . مبروك عليك تفعيل الناطق العربي . لك حرية الإختيار بتفعيل اللغة العربية أو لا ، ويمكنك الإنتقال لباقي الشرح . تابع معي :- الآن جاء دور الموظفين الذي سيكون لهم جميعهم نموذج واحد بنفس الأكواد بدون أي فرق لا في الشكل ولا في طريقة العمل ، انظر الصورة لاستكمال الشرح :- صورة لواجهة الموظف ( الشباك 1 ) والأمر نفسه لباقي الموظفين . ماذا يمكن للموظف أن يفعل هنا ؟ فقط النقر على الزر الذي سيكون مفعلاً عند وجود عملاء في الإنتظار ( استدعاء التالي & عدد العملاء الذين في الإنتظار ) كما في الصورة التالية :- فقط بعد النقر سيتم استدعاء العميل الأول في الانتظار ( حسب وقت الحجز طبعاً ) الى الشباك 1 :- طبعاً من المزايا المتاحة للموظف ، تحويل عميله الى موظف آخر ( ذو اختصاص على سبيل المثال ) ... إلخ . أو أن يطلب استراحة ( عند عدم انشغاله في عميل ) بأن يكون غير متاح في هذه الفترة لتلقي العملاء .... إلخ . وأيضاً بدء وانهاء خدمة العميل . وطبعاً الأمر ينطبق على جميع الموظفين . ثالثاً :- لوحة عرض العملاء في الإنتظار ، ذات واجهة بسيطة ومريحة كالتالي :- ليس بها أي تعقيد أو أمور تتطلب اعدادات أو ضبط خاص . رابعاً :- شاشة تحكم المدير ، وبهذه الواجهة سنشرحها في نقاط .. الجهة اليمنى تمثل إحصائيات واضحة للمدير عن تفاصيل حركة الدور ... الأزرار في أسفل يمين الشاشة تمثل :- • زر مخصص لتفعيل / تعطيل الناطق الصوتي لرقم الدور . • زر تحديث يدوي = تحديث للتفاصيل الظاهرة للشاشة بشكل يدوي . • زر تعيين القيمة التلقائية للتحديث = عند النقر عليه سيتم اظهار قائمة بسيطة تمثل رقم الدقائق التي تريد للنظام أن يتم تحديثه بشكل تلقائي دون الحاجة الى التحديث اليدوي . • زر إنهاء جميع العملاء العالقين = للطواري في حين حدوث أي خلل أو انقطاع الكهرباء أو الخروج لأي موظف دون انهاء عميله ، أو وجود عملاء لهم حجز وليسوا موجودين ... إلخ . الجهة اليسرى العلوية وتمثل العملاء الذين في الانتظار ( رقم الدور و الوقت الذي تم الحجز فيه ) . الكومبوبوكس الذي يمثل الموظفين المتاحين الآن ، وعند اختيار اي موظف سيتم عرض حالته ( متفرغ - في استراحة - يخدم عميل رقم .. ) وهنا تأتي صلاحيات المدير بأن يقوم بتحويل عميل هذا الموظف الى عميل محدد أو إعادته إلى حالة الإنتظار ( وهنا سيكون لهذا العميل الحق بالوصول لأول موظف متفرغ "VIP" ) .أو أن يتم من الإدارة إنهاء خدمة العميل الذي يخدمه الموظف الذي تم اختياره . إمكانية عرض الساعة باللغتين العربية والإنجليزية عند النقر على الساعة فقط . تم تقسيم قاعدة البيانات الى قواعد امامية وقاعدية بيانات خلفية ( للجداول المشتركة ) . وميزات كثيرة ستجدونها في هذا العمل المتواضع . Queue Management System.zip الإصدار الجديد 1.30

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Option Explicit Sub GetData() On Error GoTo EndClear Dim WS As Workbook, CrWS As Worksheet, dest As Worksheet, i As Long, tmp As Long Dim début As Long, tbl1 As Long, tbl2 As Long, ColArr As Variant, xPath As String ColArr = Split("1 2 3 4"): SetApp False Set dest = ThisWorkbook.Sheets("Sheet1"): xPath = ThisWorkbook.Path & "\aa.xlsb" If Dir(xPath) = "" Then MsgBox "الملف غير موجود: " & xPath, vbExclamation: GoTo CleanExit Set WS = Workbooks.Open(xPath) Set CrWS = WS.Sheets("Sheet1") If IsEmpty(dest.Cells(1, 1)) Then For i = 0 To UBound(ColArr) dest.Cells(1, i + 1).Value = CrWS.Cells(1, CLng(ColArr(i))).Value Next i End If début = 2: tbl1 = CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row: tmp = tbl1 - début + 1 If tmp <= 0 Then MsgBox "لا توجد بيانات للنسخ", vbExclamation: GoTo CleanExit tbl2 = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1 For i = 0 To UBound(ColArr) dest.Cells(tbl2, i + 1).Resize(tmp).Value = _ CrWS.Cells(début, CLng(ColArr(i))).Resize(tmp).Value Next i Application.Goto dest.Range("A1"), True CleanExit: If Not WS Is Nothing Then WS.Close False SetApp True If tmp > 0 Then MsgBox "تم ترحيل البيانات بنجاح", vbInformation Exit Sub EndClear: Resume CleanExit End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub ترحيل v2.rar

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

وعليكم السلام ورحمة الله وبركاته ,, هذه محاولة بسيطة قد لا تكون بدقة فكرة الأستاذ @hegazee :- Private Sub Worksheet_Change(ByVal Target As Range) Dim c As Range, val As String Dim regex As Object Set regex = CreateObject("VBScript.RegExp") regex.Pattern = "^\d{1,2}-([a-zA-Z][1-9]\d*|[1-9]\d*[a-zA-Z]?)$" For Each c In Intersect(Target, Columns("E")) If Not IsEmpty(c) Then val = c.Value If Not regex.Test(val) Or Len(val) > 8 Then MsgBox "صيغة غير صحيحة! يجب أن تكون:" & vbCrLf & vbCrLf & _ "تستخدم شرطة (-) فقط (.1)" & vbCrLf & _ "لا تبدأ الأرقام بصفر (.2)" & vbCrLf & _ "لا يوجد صفر بعد الحرف الإنجليزي (.3)" & vbCrLf & _ "(12-a1234 :مثال ) الحد الأقصى 8 أحرف (.4)", _ vbExclamation + vbMsgBoxRight, "تصحيح" Application.Undo End If End If Next c End Sub جربها وأخبرنا بالنتيجة ..

و عليكم السلام ورحمة الله و بركاته جرب الكود التالي في حدث الصفحة Private Sub Worksheet_Change(ByVal Target As Range) Dim cell As Range Dim inputValue As String Dim parts() As String Dim secondPart As String Dim hasLetter As Boolean Dim letterPos As Integer Dim i As Integer Dim errorMsg As String ' التحقق من أن التغيير حدث في العمود E (العمود الخامس) If Not Intersect(Target, Me.Columns(5)) Is Nothing Then Application.EnableEvents = False ' تعطيل الأحداث مؤقتًا لتجنب التكرار For Each cell In Intersect(Target, Me.Columns(5)) If Not IsEmpty(cell) Then inputValue = Trim(cell.Value) errorMsg = "" ' التحقق من وجود الشرطة المائلة (/) If InStr(inputValue, "/") > 0 Then errorMsg = errorMsg & "خطأ: يجب استخدام الشرطة العادية (-) بدلاً من الشرطة المائلة (/)." & vbCrLf End If ' التحقق من التنسيق العام If InStr(inputValue, "-") > 0 Then parts = Split(inputValue, "-") If UBound(parts) = 1 Then secondPart = parts(1) ' التحقق من وجود صفر في بداية الجزء الثاني If Left(secondPart, 1) = "0" Then errorMsg = errorMsg & "خطأ: لا يُسمح بوجود صفر (0) بعد الشرطة (-)." & vbCrLf End If ' التحقق من وجود حرف إنجليزي في الجزء الثاني hasLetter = False letterPos = 0 For i = 1 To Len(secondPart) If secondPart Like "*[a-zA-Z]*" Then hasLetter = True Exit For End If Next i ' التحقق من وجود صفر بعد الحرف الإنجليزي (إن وجد) If hasLetter Then letterPos = InStr(secondPart, Left(secondPart, 1)) If letterPos > 0 And Mid(secondPart, letterPos + 1, 1) = "0" Then errorMsg = errorMsg & "خطأ: لا يُسمح بوجود صفر (0) بعد الحرف الإنجليزي." & vbCrLf End If End If Else errorMsg = errorMsg & "خطأ: تنسيق رقم الحالة غير صحيح. يجب أن يكون على شكل (أرقام-أرقام) أو (أرقام-حرف أرقام)." & vbCrLf End If Else errorMsg = errorMsg & "خطأ: يجب أن يحتوي رقم الحالة على شرطة عادية (-)." & vbCrLf End If ' إذا كان هناك خطأ، عرض رسالة تحذير وإلغاء الإدخال If errorMsg <> "" Then MsgBox errorMsg, vbCritical, "خطأ في إدخال رقم الحالة" cell.Value = "" End If End If Next cell Application.EnableEvents = True ' إعادة تفعيل الأحداث End If End Sub Book1.xlsm

استاذنا الفاضل Foksh جزاك الله كل خير وجعله فى ميزان حسناتكم برجاء قبول شكرى وتقديرى واحترامى لشخصكم الكريم ادام الله عليكم نعمه وفضله

وعليكم السلام ورحمة الله وبركاته ,,, تمام فهمتك ، جرب التعديل ده :- Private Sub Worksheet_Change(ByVal Target As Range) Dim c As Range, valToCheck As Variant Dim duplicateFound As Boolean Dim lastRow As Long, i As Long On Error Resume Next Set c = Intersect(Target, Columns("E")) If c Is Nothing Then Exit Sub Application.EnableEvents = False valToCheck = c.Value If valToCheck <> "" Then lastRow = Cells(Rows.Count, "E").End(xlUp).Row duplicateFound = False For i = 1 To lastRow If i <> c.Row And Cells(i, "E").Value = valToCheck Then If WorksheetFunction.CountBlank(Range("K" & i & ":N" & i)) = 4 Then MsgBox "الحالة سبق ادخالها ولم يتم بشانها اجراء", vbExclamation + vbMsgBoxRight, "تنبيه" c.ClearContents duplicateFound = True Exit For End If End If Next i If Not duplicateFound Then Cells(c.Row, "D").Value = Date End If End If Application.EnableEvents = True End Sub

الف مبروك اخى فادى_ من تقدم لتقدم ان شاء الله

الف الف مبروووك يا فوووكش ♥️ @Foksh تستاهل كل خير ، مشالله عليك دائما متألق

الف مبروك بشمهندس فادي انضمامك لفريق الموقع في المنتدى اهنئك من كل قلبي

حسن في كل عين من تود الحقيقة من تجربة لانظمة التشغيل من dos 3 الى ويندوز 11 اقول لا يوجد نظام تشغيل من مايكروسوفت يمكن مقارنته بويندوز 11 وخصوص الاصدار 24H2 والحديث عن المزايا يستغرق الكثير من الوقت وعليه اكتفي ببعض المزايا دون الدخول في التفاصيل الامان المحسن ولا يقتصر على مراقبة السلوك المشبوه لبعض التطبيقات وانما يتطلب توفر امكانية التمهيد الامن وكذلك tpm2 وهي معيار امان لتخزين مفاتيح التشفير والشهادات بشكل آمن ويوفر التحقق من سلامة النظام الأساسي قبل الاقلاع دعم افضل للذكاء الصناعي تكامل تام من اجهزة الهاتف تلقي مكالمات وارسال واستقبال الرسائل ونقل الملفات واستعراضها بدون برامج اضافيه يقدم افضل تجربة لمحبي الالعاب ادارة افضل للذاكرة ويقدم كذلك تحسين على نظام الذاكرة الظاهرية وخصوصا عند استخدام اقراص m.2 من الجيل الرابع او الخامس لوحة الاشعارات والتنبيهات افضل و من خلال مكان واحد ويمكن التحكم فيها وتحديد الاشعارات المرغوب بها وايقاف اي تطبيق لا ترغب في تمكين اشعاراته ويمكن تخصيص وقت لعدم الازعاج لوحة المفاتيح المدمجة يمكن تكبيرها وتعديلها وفقا لاحتياجك وهي مفيدة لمن لايملك لوحة مفاتيح تحويل اي صورة الى نص بدون الحاجة الى برامج وتعمل بشكل ممتاز مع اللغة العربية ادارة المهام افضل ويمكن البحث عن اي تطبيق بدون الحاجة لاستعراض كافة التطبيقات يمكن تفعيل Sudo وهي ميزة تسمح للادمن بالحصول على امتيازات وتحكم اكبر في النظام و هذه الميزة يعرفها كل من لدية خبرة بانظمة التشغيل المستندة على منصة Linux مثل اوبنتو وديبيات وفيدورا ومينت وغيرها من هذه التوزيعات مستكشف الملفات افضل ويمكن فتح عدة تبويبات والتنقل بينهم بكل سهولة توجد العديد من التحسينات مثل الوضع المحمي للطباعة ميزة مفيدة للشركات وبيئات تعدد المستخدمين وكذلك ميزة عدم التشتيت من خلال التحكم في الاشعارات والتنبيهات وغيرها من مميزات ولكني اكتفي بما سبق و للحصول على افضل تجربة تجنب استخدام نسخ معدلة وان يكون جهازك يحقق متطلبات تشغيل ويندوز 11 وعدم استخدام نسخ تسمح بتجاوز متطلبات التشغيل باستخدام برنامج Rufus او اي برنامج مشابه تسمح بتجاوز هذه المتطلبات والنصيحة الذهبية عدم استخدام الكراك او الكيجن والحرص على تحديث النظام . اخيرا بعض المستخدمين لا يستطيع التاقلم مع الواجهة الجديدة وهذه ليست مشكلة في النظام. الشايب

العفو جميعا هذا ليس مجهودي فقط وانما انتهي هذا البرنامج بمجهود ومشاركة العديد من خبراء ادارة الموقع ممن يحضروني @jjafferr @ابوخليل @رمهان @Shivan Rekany الشكر لله سبحانه وتعالي ثم الاخوة الذين تجاوبوا لحل المشاكل لي ولغيري من الاعضاء لنظهر بمثل هذه البرامج . رابط نواة 32 بت السابق ارفاقة في المكتبة وتم ارفاق نسخة تعمل على 64 بت امل تجربتها للتاكد من عملها على النواة المطلوبة @Mohamed Wahba @عاشق_الرقي برنامج العطاء للعقار 3.7 نواة 64 بت.rar

اعرض الملف تخصيص العلامة المائية للتقارير بطريقتين {سلسلة الأدوات المساعدة المخصصة} تقوم هذه الأداة بتخصيص العلامة المائية للتقارير بطريقتين - إما أن تكون العلامة المائية عبارة عن نص كما بالصورة - أو تكون صورة كما في الصورة التالية مع تحياتي صاحب الملف منتصر الانسي تمت الاضافه 06/23/25 الاقسام قسم الأكسيس  

وعليكم السلام ورحمة الله وبركاته ,, بناءً على ما فهمته من هذا الكم الهائل من المعطيات 😅 ، جرب هذا التعديل ، حيث تم التعديل عى كودك الأصلي ليصبح = Private Sub أمر1069_Click() On Error GoTo ErrorHandler DoCmd.SetWarnings False DoCmd.RunSQL "DELETE FROM tab_degree_mauel" DoCmd.RunSQL "INSERT INTO tab_degree_mauel(code_fonct, nom_prenom, grade_actuel, categorie, numero_indice_categorie, degre, numero_indice_degre, duree, date_effet, faid_31_12, date_signature_decision, date_reunion_comession, date_calcul_faid_31_12, num_decision) " & _ "SELECT code_fonct, nom_prenom, grade_actuel, categorie, numero_indice_categorie, degre, numero_indice_degre, duree, date_effet, faid_31_12, date_signature_decision, date_reunion_comession, date_calcul_faid_31_12, num_decision " & _ "FROM tab_degree_saisie" DoCmd.RunSQL "DELETE FROM tbl_info_fonctionnaire" DoCmd.RunSQL "INSERT INTO tbl_info_fonctionnaire(num, grade, num_indice_grade, date_effet_grade_actuel) " & _ "SELECT code_fonct, degre, numero_indice_degre, date_effet " & _ "FROM tab_degree_saisie t1 " & _ "WHERE degre = (SELECT MAX(degre) FROM tab_degree_saisie t2 WHERE t2.nom_prenom = t1.nom_prenom)" DoCmd.SetWarnings True Me.Requery MsgBox "تم تحديث البيانات في الجدولين بنجاح", vbInformation + vbMsgBoxRight, "تنبيه" Exit Sub ErrorHandler: DoCmd.SetWarnings True MsgBox " : حدث خطأ أثناء تنفيذ العملية " & Err.Description, vbCritical + vbMsgBoxRight, "خطأ" End Sub أخبرنا بالنتيجة baseZ.zip

وعليكم السلام ورحمة الله وبركاته ,, لم اجد الكود الذي تتحدث عنه ،ولكن قم بالتعديل للدالة التي في الملف السابق الى التالي :- Private Sub Worksheet_Change(ByVal Target As Range) Dim c As Range, valToCheck, foundCell As Range Dim duplicateFound As Boolean On Error Resume Next Set c = Intersect(Target, Columns("E")) If c Is Nothing Then Exit Sub Application.EnableEvents = False valToCheck = c.Value If valToCheck <> "" Then Set foundCell = Columns("E").Find(valToCheck, LookIn:=xlValues) If Not foundCell Is Nothing And foundCell.Row <> c.Row Then If WorksheetFunction.CountBlank(Range("K" & foundCell.Row & ":N" & foundCell.Row)) = 4 Then MsgBox "الحالة سبق ادخالها ولم يتم بشانها اجراء", vbExclamation + vbMsgBoxRight, "تنبيه" c.ClearContents duplicateFound = True End If End If If Not duplicateFound Then Cells(c.Row, "D").Value = Date End If End If Application.EnableEvents = True End Sub وأخبرني بالنتيجة

ما شاء الله جعله الله فى ميزان حسناتكم

كذلك يمكن عند طباعة أصل ونسختين إضافة كلمة صورة للنسختين

اعرض الملف تظليل السجل الحالي في النماذج المستمرة {سلسلة الأدوات المساعدة المخصصة} الأداة الثانية لهذا اليوم وهي أداة تقوم بتظليل السجل الحالي أثناء التنقل خلال النماذج المستمرة مايمز الأداة هو سهولة الإستفادة منها وتنوع الخيارات فيها فمثلاً يمكن تحديد لون التظليل بلون محدد وهذه بعض الصور التوضيحية طريقة العمل وطربقة الإستفادة منها موضحة في الملف المرفق مع تحياتي صاحب الملف منتصر الانسي تمت الاضافه 06/23/25 الاقسام قسم الأكسيس  

اعرض الملف ترقيم صفحات التقرير وفقاً للمجموعات الفرعية {سلسلة الأدوات المساعدة المخصصة} اليوم نواصل العمل مع سلسلة الأدوات المساعدة المخصصة بأداة مهمة ورائعة تقوم بعملين - ترقيم صفحات التقرير بحسب المجموعة - إنشاء تقرير بجدول محتويات التقرير والذي يمكن إعتباره كقائمة الفهرس للتقرير يحتوي المثال على ثلاثة تقارير الأول يوضح طريقة إظهار أرقام الصفحات عندما يحتوي التقرير على مستوى تجميع واحد كما في الصورة وسيكون فهرس محتويات التقرير كالتالي التقرير الثاني عندما يكون في التقرير إثنين مستويات تجميع وسيظهر كالتالي وسيكون فهرس محتويات التقرير كالتالي فهرس محتويات التقرير هو نفس التقرير في الحالتين وإنما يختلف التنسيق بحسب عدد مستويات التجميع طريقة عمل الأداة وطريقة الإستفادة منها في تطبيقاتكم الخاصة موضحة ضمن المثال الرفق صاحب الملف منتصر الانسي تمت الاضافه 06/23/25 الاقسام قسم الأكسيس  

السلام عليكم ولكن نصيحة انصحكم بها ويندوز 10 سوف يتم ايقاف الدعم عنه فى اكتوبر القادم من اجل ذلك التحديث تم الى ويندوز 11 بشكل صارم وسوف يأتى عليه وقت وكما هو الحال مع ويندوز 7 الان لن تجد المتصفحات مدعومة ولا بعض البرامج فى المستقبل مع ويندوز 10 كما هو الحال الان مع ويندوز 7 و ويندوز XP

السلام عليكم أسوق لكم تجربتي الطازجة : انا استخدم وندوز 10 قبل يومين وعند اقلاع الحاسوب اظهر على الشاشة ( الجحش وندوز ) واعذروني على الوصف .. أظهر على الشاشة امامي انه سوف يقوم بالتحديث لم يعطني خيارا للرفض .. لا يوجد الا زر واحد للمتابعة قلت ماشي يمكن يريد يحدث ملفات النظام لوجود خلل بها الجحش ركب لي وندوز 11 تصفحته .. حلو .. الوان جميلة .. وتبويبات لها اول وليس لها آخر في وندز 10 كان كل شيء بجانبي وسهل الوصول اليه .. اما هذا فيحتاج الى خطوات وقوائم واحدة خلف الأخرى من اجل اصل الى الخصيصة المطلوبة صحيح انه مطور لخاصية اللمس ، ولكني رجل عجوز .. اعتدت على كل شيء قريب مني اسلمت أمري الى الله .. وقلت اتعايش معه واصبر واتحمل حتى اعتاد عليه .. لن أكون اضعف ممن اخذ على ام اولاده ، فتاة عروسا وروضها للعلم الملف الذي يتم تحزيمه accde على 11 لا يعمل على 10 ولكنه اليوم ركز رأسه في الجدار وقال لي : ربي وربك واحد لن اجعلك تهتني في عروسك الجديدة بدأت الملفات تومض وترتعش كأن بها حمى ولم اتمكن من فتحها . اتصلت بأهل العلم والخبرة فأفادوني ان كل هذه الافاعيل من برنامج الحماية المدرج ضمن وندوز وأشاروا علي بالتراجع .. الى الاصدار السابق .. حيث يوجد ايقونة في النظام خاصة بهذا الشان تسمح بالاستعادة الحمد لله طبقت النصيحة ورجعت الى دياري سالما .

وعليكم السلام ورحمة الله تعالى وبركاته إليك الكود المطلوب لحفظ جميع الشهادات في ملف PDF داخل مجلد باسم برنامج الكنترول شيت في نفس مكان المصنف Option Explicit Private Const CopyRange As String = "A5:J49" Private Const sFolder As String = "برنامج الكنترول شيت" Private Const NamePDF As String = "شهادات الأول" Private Const CrWS As String = "شهادات الأول بالقديرات" Private Sub CommandButton1_Click() Dim tbl As Boolean: tbl = False On Error GoTo CleanExit Dim f As Worksheet: Set f = Sheets(CrWS) Dim WS As Worksheet, début As Integer, fin As Integer, i As Integer, row As Integer Dim sPath As String, tempFile As String, tmp As Long, Rng As Range, OnRng As Range If IsEmpty(f.[J3].Value) Or Not IsNumeric(f.[J3].Value) Then _ MsgBox "يرجى تحديد رقم أول شهادة", vbExclamation, "تنبيه": Exit Sub début = f.[J3].Value: fin = f.[R3].Value If début < 1 Or fin < 1 Or début > fin Then Exit Sub If MsgBox("هل ترغب بحفظ الشهادات من " & _ début & " إلى " & fin & "؟", vbYesNo + vbExclamation, "تأكيد") = vbNo Then Exit Sub SetApp False On Error Resume Next Set WS = Sheets("PDF") If Not WS Is Nothing Then Application.DisplayAlerts = False: WS.Delete: Application.DisplayAlerts = True Set WS = Sheets.Add(After:=Sheets(Sheets.Count)) WS.Name = "PDF": WS.DisplayRightToLeft = True On Error GoTo 0 If WS Is Nothing Then: GoTo CleanExit tempFile = ThisWorkbook.Path & "\" & sFolder If Dir(tempFile, vbDirectory) = "" Then MkDir tempFile tmp = 1 Set OnRng = f.Range(CopyRange) For i = début To fin Step 5 f.[J3].Value = i: Set Rng = WS.Cells(tmp, 2) OnRng.Copy Rng.PasteSpecial Paste:=xlPasteValues: Rng.PasteSpecial Paste:=xlPasteFormats Rng.PasteSpecial Paste:=xlPasteColumnWidths For row = 1 To OnRng.Rows.Count WS.Rows(tmp + row - 1).RowHeight = OnRng.Rows(row).RowHeight - 1.5 Next If i + 5 <= fin Then WS.HPageBreaks.Add Before:=WS.Cells(tmp + OnRng.Rows.Count, 1) tmp = tmp + OnRng.Rows.Count + 1 Next With WS.PageSetup .Orientation = xlPortrait: .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = False .TopMargin = Application.InchesToPoints(0.5): .BottomMargin = Application.InchesToPoints(0.5) .LeftMargin = Application.InchesToPoints(0.2): .RightMargin = Application.InchesToPoints(0.2) .PaperSize = xlPaperA4: .CenterHorizontally = True: .CenterVertically = False End With sPath = tempFile & "\" & NamePDF & ".pdf" On Error Resume Next WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False tbl = (Err.Number = 0) On Error GoTo 0 f.[J3].Value = 1 WS.Delete CleanExit: SetApp True MsgBox IIf(tbl, _ "تم تصدير جميع الشهادات بنجاح" & vbNewLine & _ "تم حفظ الملف باسم: " & NamePDF & vbNewLine & "في المجلد: " & sFolder, _ "حدث خطأ يرجى المحاولة مرة أخرى"), IIf(tbl, vbInformation, vbCritical), _ "PDF" & "تصدير الشهادات بصيغة" End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable End With End Sub وإليك في المرفقات شكل الملف PDF المستخرج بعد تنفيذ العملية لتأخذ فكرة واضحة عن النتيجة النهائية شهادات الأول والثانى- الصف الأول.rar شهادات الأول.pdf

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub Tartib() Dim WS As Worksheet, lastRow As Long, OnRng As Range Dim i As Long, ColSort As String: ColSort = "Z" Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set WS = ThisWorkbook.Sheets("Sheet1") lastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row If lastRow < 2 Then GoTo ClearApp For i = 2 To lastRow WS.Cells(i, ColSort).Value = i Next i Set OnRng = WS.Range("A2:D" & lastRow).Resize(, WS.Range(ColSort & "2").Column - 1 + 1) OnRng.Sort Key1:=WS.Range(ColSort & "2"), Order1:=xlAscending, Header:=xlNo OnRng.Sort Key1:=WS.Range("C2"), Order1:=xlDescending, _ Key2:=WS.Range("D2"), Order2:=xlAscending, _ Key3:=WS.Range("B2"), Order3:=xlAscending, Header:=xlNo WS.Range(ColSort & "2:" & ColSort & lastRow).ClearContents ClearApp: Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

تمام استاذنا / عبدالله بشير جعله الله في ميزان حسناتك وبارك الله فيك