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

السلام عليكم 🙂 تلقائياً ، مايكروسوفت ستوقف عمل كائنات ActiveX في جميع برامج الاوفيس ، ابتدأ من الاوفيس 2024 اصدار شهر 10 ، وكذلك في برنامج MS365 ابتدأ من 4/2025 : https://petri.com/microsoft-changelog/m365-changelog-updated-activex-will-be-disabled-by-default-in-microsoft-office-2024-sep-6-2024/ نعم يستطيع المستخدم ان يعيد عمل كائن ActiveX عن طريق مجلد الامان او الريجستري. هذا سيشمل: . انا كمبرمج مسؤول عن برنامجي عند المستخدم ، فلذلك ، يالله بسرعة عدلوا على برامجكم قبل ان تتوقف عن العمل فجأة جعفر

مع ان الموضوع مو واضح 100% بالنسبة الى نسخ الاكسس المتأثرة ، ولكن الظاهر ان النسخ القديمة لن تتأثر ، وانما هو الحال للنسخة 2024 وما بعدها ، ولكني سأخذ الحيطة من الان ، لأن المستخدم بعد سنة او سنتين سيكون قد انتقل الى النسخة 2024 او ما بعدها.

ومشاركة مع الأساتذة ، الخبر سليم وأيضاً آكسيس من ضمن التطبيقات التي سيتم ايقاف الـ ActiveX لبعض الوظائف منها :- Microsoft Web Browser Control Microsoft Windows Media Player Control Date and Time Picker Control Microsoft TreeView Control Microsoft ListView Control حيث سيتم تعطيل إعدادات ActiveX في مركز الثقة لجميع البرامج التي شملها الحظر ، بما في ذلك أكسس . وهذه مصادر خارجية :- الموقع الأول الموقع الثاني الموقع الثالث

حلوة وقوية الحركة دي مهندسنا الغالي ,, اعتقد أن جملة : Exit Sub جعلت من هذا الجزء ErrorHandler: If Err.Number <> 0 Then MsgBox "حدث خطأ أثناء الحفظ: " & Err.Number & " - " & Err.Description, vbCritical Resume Next End If وكأنه غير موجود حتى لو ظهر خطأ ، فسيتم الخروج من الـ Sub قبل الوصوا الى ErrorHandler ، وعليه فإنه في الملف الأصلي لأخونا @yazan_2 لو استخدم Exit Sub قبل جملة ErrorHandler ، فأعتقد أنه لن تظهر عنده رسائل الخطأ بعد الحفظ أو التعديل . هذا من ناحية المشكلة التي تظهر بعد حفظ السجل أو تحديثه . من ناحية أخرى ، ارتأيت هذا التعديل على الكود لإتمام عملية الحفظ كسجل جديد أو تحديث السجل الحالي من خلال :- Private Sub BtnSave_Click() On Error GoTo ErrorHandler If IsNull(Me.NatiID) Or Trim(Me.NatiID) = "" Then MsgBox "يرجى إدخال قيمة في حقل رقم الهوية.", vbExclamation Exit Sub End If Set db = CurrentDb() strSQL = "SELECT * FROM Employees WHERE NatiID = '" & Me.NatiID & "'" Set rs = db.OpenRecordset(strSQL, dbOpenDynaset) If rs.EOF Then rs.AddNew MsgBox "تم إضافة موظف جديد." Else rs.Edit MsgBox "تم تحديث بيانات الموظف." End If rs!NatiID = Me.NatiID rs!FName = Me.FName rs!LName = Me.LName rs!GName = Me.GName rs!FamName = Me.FamName rs!Rank = Me.Rank rs!BirthDate = Me.BirthDate rs!Age = Me.Age rs!BirthPlace = Me.BirthPlace rs.Update rs.Close Set rs = Nothing Set db = Nothing Exit Sub ErrorHandler: MsgBox "حدث خطأ أثناء الحفظ: " & Err.Description, vbCritical Resume Next End Sub طبعاً فيما يخص المتغيرات فلم أعدل عليها شيء وتركتها كما هي في مكان حجزها أول الأكواد Option Compare Database Dim db As DAO.Database Dim rs As DAO.Recordset Dim strSQL As String هذا كله رأيي الشخصي وليس فرضاً

اشكرك استاذى ومعلمى / الاستاذ موسى واكتفى باختفاء الجداول وجزاك كل خير وجعلك خير عونا لنا

الله الله الله عليك استاذى ومعلمى القدير الله يفتح عليك ويزيدك من علمه هذا هو المطلوب ومرادى ولكن توجد ملحوظة صغيرة هو لا يخفى النماذج لماذا ؟ وهذا بالنسبة لى غير مهم ـ المهم انه يخفى الجداول ويعمل على عدم استيرادها ان امكن اخفاء النماذج كان افضل ولكن غير هام الله يبارك لك ويجعلك زخرا لنا ويرحم والديك ويبارك فى اولادك واهلك ـ ويجعلك من اهل الجنة ان شاء الله

أجريت هذا التعديل .. وربما يكون للخبراء رأي بخصوص Resume Next 🙂 : test.rar

السلام عليكم 🙂 اهلا وسهلا بك بيننا مرة اخرى 🙂 اليك هذا التحذير من مايكروسوفت: . منذ 2017 وانا استخدم هذا الخط في برامجي وبدون مشاكل: . الى ان تصل الى هذا السطر: . وطريقة التنصيب موجودة في نهاية المقالة 🙂

العفو أخي @ahmed sewelam يسعدنا أننا إستطعنا مساعدتك ' تحويل القيمة المدخلة الى تاريخ MinDate و MaxDate MinDate = CDate(TextBox1.Value) MaxDate = CDate(TextBox2.Value) ' جلب البيانات من النطاق A3:I a = WS.Range("A3:I" & WS.Cells(Rows.Count, 1).End(xlUp).Row).Value ' قواميس لتخزين البيانات المجمعة ' dc لتخزين صافي المبيعات، dnc لتخزين صافي المردودات، dnc1 لتخزين المندوب Set dc = CreateObject("Scripting.Dictionary") Set dnc = CreateObject("Scripting.Dictionary") Set dnc1 = CreateObject("Scripting.Dictionary") For i = 1 To UBound(a, 1) 'MinDate و MaxDate إذا كان التاريخ ' (العمود B) a(i, 2)' 'يقع بين If a(i, 2) >= MinDate And a(i, 2) <= MaxDate Then tmp = Trim(a(i, 7)) ' العمود G: "المندوب" ' إذا لم يكن المندوب موجودا مسبقا في القاموس نقوم بإضافته وتخزين القيم المبدئية If Not dc.Exists(tmp) Then dnc1(tmp) = a(i, 6) ' العمود F: "تخزين اسم المندوب" dc(tmp) = a(i, 8) ' العمود H: "تخزين صافي المبيعات" dnc(tmp) = a(i, 9) ' العمود I: "تخزين صافي المردودات" Else ' إذا كان المندوب موجودا إضافة القيم إلى القيم المخزنة dc(tmp) = dc(tmp) + a(i, 8) ' تجميع عدد المبيعات dnc(tmp) = dnc(tmp) + a(i, 9) ' تجميع المردودات End If End If Next i 'إذا كانت القواميس تحتوي على بيانات (dc.Count > 0) ' مطابقة للفترة الزمنية المحددة If dc.Count > 0 Then Application.ScreenUpdating = False 'مسح أي محتوى سابق من النطاق C12:F في ورقة "Report" With dest.Range("C12:F" & dest.Rows.Count) .ClearContents .ClearFormats End With ' تعيين حجم المصفوفة arr بناءا على عدد العناصر في القاموس dc n = 1 ReDim arr(1 To dc.Count, 1 To 4) ' تعبئة المصفوفة For Each key In dc.Keys arr(n, 1) = dnc1(key) ' العمود الأول في arr: "كود" arr(n, 2) = key ' العمود الثاني : "المندوب" arr(n, 3) = dc(key) ' العمود الثالث : "إجمالي المبيعات" arr(n, 4) = dnc(key) ' العمود الرابع : "إجمالي المردودات" n = n + 1 Next key ' نسخ محتويات المصفوفة "Report"(C12) بداية من الخلية dest.Range("C12").Resize(dc.Count, 4).Value = arr ' تحديد الصف الأخير المستخدم بعد إدراج البيانات lastRow = dest.Cells(dest.Rows.Count, "E").End(xlUp).Row ' إضافة "الإجمالي" في العمود D أسفل البيانات dest.Cells(lastRow + 1, "D").Value = "الإجمالي" 'وضع الإجمالي أسفل التقرير ' للأعمدة E و F (صافي المبيعات وصافي المردودات)' For Each col In Array("E", "F") dest.Cells(lastRow + 1, col).Value = Application.WorksheetFunction.Sum(dest.Range(col & "12:" & col & lastRow)) Next col ' يتم وضع تاريخ البداية والنهاية في الخلايا E9 و F9 dest.Range("E9").Value = MinDate dest.Range("F9").Value = MaxDate ' نطاق البيانات في التقرير Set Rng = dest.Range("C12:F" & lastRow) ' إضافة حدود حول كل صف في التقرير يحتوي على بيانات For Each C In Rng.Rows If Application.WorksheetFunction.CountA(C) > 0 Then C.Borders.LineStyle = xlContinuous End If Next C

اضافة للكود استدعاء اسم المادة ورمز المادة الافادة.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Private Sub CommandButton1_Click() Dim MinDate As Date, MaxDate As Date Dim WS As Worksheet, dest As Worksheet Dim a As Variant, tmp As String Dim dc As Object, dnc As Object, dnc1 As Object Dim arr() As Variant, n As Long, lastRow As Long, i As Long Dim Rng As Range, C As Range, col As Variant, key As Variant Set WS = Sheets("DATA"): Set dest = Sheets("Report") If Not IsDate(TextBox1.Value) Or Not IsDate(TextBox2.Value) Then MsgBox "المرجوا التحقق من التواريخ", vbExclamation Exit Sub End If MinDate = CDate(TextBox1.Value) MaxDate = CDate(TextBox2.Value) a = WS.Range("A3:I" & WS.Cells(Rows.Count, 1).End(xlUp).Row).Value Set dc = CreateObject("Scripting.Dictionary") Set dnc = CreateObject("Scripting.Dictionary") Set dnc1 = CreateObject("Scripting.Dictionary") For i = 1 To UBound(a, 1) If a(i, 2) >= MinDate And a(i, 2) <= MaxDate Then tmp = Trim(a(i, 7)) If Not dc.Exists(tmp) Then dnc1(tmp) = a(i, 6): dc(tmp) = a(i, 8): dnc(tmp) = a(i, 9) Else dc(tmp) = dc(tmp) + a(i, 8): dnc(tmp) = dnc(tmp) + a(i, 9) End If End If Next i If dc.Count > 0 Then Application.ScreenUpdating = False With dest.Range("C12:F" & dest.Rows.Count) .ClearContents: .ClearFormats End With n = 1 ReDim arr(1 To dc.Count, 1 To 4) For Each key In dc.Keys arr(n, 1) = dnc1(key): arr(n, 2) = key: arr(n, 3) = dc(key): arr(n, 4) = dnc(key) n = n + 1 Next key dest.Range("C12").Resize(dc.Count, 4).Value = arr lastRow = dest.Cells(dest.Rows.Count, "E").End(xlUp).Row dest.Cells(lastRow + 1, "D").Value = "الإجمالي" For Each col In Array("E", "F") dest.Cells(lastRow + 1, col).Value = Application.WorksheetFunction.Sum(dest.Range(col & "12:" & col & lastRow)) Next col dest.Range("E9").Value = MinDate: dest.Range("F9").Value = MaxDate Set Rng = dest.Range("C12:F" & lastRow) For Each C In Rng.Rows If Application.WorksheetFunction.CountA(C) > 0 Then C.Borders.LineStyle = xlContinuous End If Next C Else MsgBox "لا توجد بيانات تطابق التواريخ المحددة" End If Application.ScreenUpdating = True End Sub TEST v1.xlsm

بما أنك لم تجب عن سؤالي إليك طريقة أخرى ستقوم بإظافة عنصر جديد بإسم Line لإستخراج رقم صف المحدد عند الإختيار من عناصر الكومبوبوكس وإعتمادا عليه سنقوم بتعديل وحدف الصفوف Private Sub SearchData() Dim fnd As Range Dim ColA As String, ColB As String, ColC As String Dim criteria As Range, found As Boolean Dim rowNum As Long ColA = Me.ComboBox1.Value ColB = Me.ComboBox2.Value ColC = Me.ComboBox3.Value If Len(ColA) = 0 Then Exit Sub Set criteria = WS.Range("A4:C" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row) found = False For Each fnd In criteria.Rows If fnd.Cells(1, 1).Value = ColA And _ (ColB = "" Or Format(fnd.Cells(1, 2).Value, "dd-mmm") = ColB) And _ (ColC = "" Or fnd.Cells(1, 3).Value = ColC) Then For i = 1 To 62 Me.Controls("TextBox" & i).Value = fnd.Cells(1, i).Value Next i rowNum = fnd.Row found = True Exit For End If Next fnd If Not found Then ClearTextBoxes Me.Line.Value = "" Else Me.Line.Value = rowNum End If End Sub Private Sub CommandButton2_Click() Dim r As Integer, n As Variant Dim i As Integer, X As Integer Dim rowNum As Long, fnd As Range If IsNumeric(Me.Line.Value) Then rowNum = CLng(Me.Line.Value) Else MsgBox " يرجى تحديدالبيانات المرغوب تعديلها", vbExclamation Exit Sub End If If rowNum < 5 Then: Exit Sub If SaisieText(1, 2) Then Exit Sub r = MsgBox("تعديل البيانات؟", vbYesNo, "تأكيـــد") If r <> vbYes Then Exit Sub Application.ScreenUpdating = False Set fnd = WS.Cells(rowNum, 1) For i = 1 To 62 On Error Resume Next n = Me.Controls("TextBox" & i).Value On Error GoTo 0 If IsDate(n) Then fnd.Offset(0, i - 1).Value = CDate(n) Else fnd.Offset(0, i - 1).Value = n End If Next i Call UpdateNum(WS) Clear_TextBox UserForm_Initialize Application.ScreenUpdating = True MsgBox "تم التعديل بنجاح", vbInformation End Sub Private Function SaisieText(startIdx As Integer, endIdx As Integer) As Boolean Dim i As Integer, X As Integer Dim arr() As String, TexArr As String For i = startIdx To endIdx If Me.Controls("TextBox" & i).Value = "" Then TexArr = Me.Controls("cnt" & i).Caption ReDim Preserve arr(X) arr(X) = TexArr X = X + 1 End If Next i If X > 0 Then MsgBox ": يرجى التحقق من " & Chr(10) & Join(arr, " - "), vbInformation SaisieText = True Else SaisieText = False End If End Function ترحيل مع كمبوبوكس البحث بحقلين V3.xlsm