كل الانشطه

مشكورين

أستاذ بارك الله فيك وجزاك الله خيرا لكن أستاذ أريد تلوين الصف وليس خلية مثلا 100 A4:F

السلام عليكم الإخوة الأفاضل في هذا المنتدى الجميل في موضوعي أريد إدراج بيانات جدول في جدولين كما يلي: الكود الموجود في النمودج في زر" تحديث " يقوم بادراج و تحديث جميع بيانات الحقول الموجودة في جدول tab_degree_saisie يقوم بادراجها في جدول tab_degree_mauel أريد الابقاء على هذا الكود وأضيف له خاصية وهي: إدراج الحقول التالية من جدول tab_degree_saisie : degre numero_indice_degre date_effet الحقول السابقة تدرج في الجول المسمى tbl_info_fonctionnaire في الحقول التالية بنفس الترتيب: grade num_indice_grade date_effet_grade_actuel مع مراعاة الشرط التالي لدينا : في جدول tab_degree_saisie لدينا الإسم: خالد مذكور مرتين: خالد عنده الحقل degre يساوي 7 وخالد عنده الحقل degre يساوي 8 هنا نقوم بادراج البيانات في حالة وجود اسماء مكررة الذي عنده الحقل degre الكبير أو الأكبر فهنا نقوم بادراج بينانات خالد في جدول tbl_info_fonctionnaire للحقل degree يساوي 8 أما إذاكان الإسم غير مكرر تدرج البانات مباشرة. وكذلك الشرط الثاني: مثال code_fonct =1 من جدول tab_degree_saisie تدرج في الجدول tbl_info_fonctionnaire في num =1 يعني خلاصة : ادراج وتحديث جميع بيانات الحقول الموجودة في جدول tab_degree_saisie يقوم بادراجها في جدول tab_degree_mauel ادراج 4 حقول كما هي مبينة أعلاه من جدول tab_degree_saisie في جدول tbl_info_fonctionnaire مع مراعاة الشرط إذا كان الإسم مذكور مرة واحدة تدرج البيانات مباشرة إذاكان الاسم مذكور عدة مرات ندرج البيانات فقط للحقل degre الذي يحمل أكبر قيمة و مراعاة الشرط الثاني : مثال code_fonct =1 من جدول tab_degree_saisie تدرج في الجدول tbl_info_fonctionnaire في num =1 نتمنى أن أكون قد أوصلت الفكرة. الرجاء المساعدة والتوجيه وبارك الله فيكم baseZ.accdb

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

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

أخي @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

هل تم تحديث ويندوز أم تم تنصيب نسخة جديدة

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

وعليكم السلام ورحمة الله وبركاته .. كفكرة بسيطة ، جرب تعديل هذا الحدث :- Private Sub ListBox1_Click() Sheets(ListBox1.Column(0)).Activate Range(ListBox1.Column(1)).EntireRow.Select TextBox2.Value = ListBox1.Column(2) End Sub الى التعديل التالي :- Private Sub ListBox1_Click() If ListBox1.ListIndex = -1 Then Exit Sub Sheets(ListBox1.Column(0)).Activate Cells.Interior.Pattern = xlNone With Range(ListBox1.Column(1)) .Interior.Color = vbYellow .Activate End With TextBox2.Value = ListBox1.Column(2) End Sub قمت باختيار اللون الأصفر كمثال ، ولك الحرية بالتعديل على مزاجك

إما بإعادة تثبيت نسخة ويندوز 11 بتحديثات جديدة ، أو العودة الى الإصدار السابق ( ويندوز 10 ) ..

جرتب 10 و 16

السلام عليكم ورحمة الله وبركاته إخواني الكرام أطلب منكم مساعدة في تلوين ناتج البحث وبارك الله فيكم بحث في عدة أوراق مع التحديد 01.xlsm

ما هو اصدار الأوفيس الذي تستخدمه بعد التحديث ؟؟

أستاذي الكريم جزاكم الله خيرا على سعة صدركم والرد علي طلبي ولكن عندما وضعت في أول الكود On Error Resume Next لم تظهر المشكلة وتم تحديث البيانات المطلوبة تماما ولكن الشي الغريب أنه لم تظهر رسالة "تم تحديث البيانات بنجاح عموما ليست ضرورية وجزاكم الله خيرا وزادكم علما وسعة صدر أقصد هكذا جعلتها Private Sub أمر136_Click() On Error Resume Next UpdateBooksToLost End Sub

ما شاء الله ، إبدااااع جميل أستاذ منتصر ، هذه الدالة والفكرة فعلاً مفيدة عندما تريد إضافة علامة مائية مثل "مسودة" أو "سري" ، أو نسخة غير مدفوعة للبرامج التي تعتمد على المدة التجريبية .... أو أي نص آخر في خلفية التقرير .

معظم الكلام بيقول اعادة تصطيب الاوفيس انا فعلاً كنت مصطبه من جديد بيجيب الرسائل ديه

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

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

أثابك الله ، راجع ملفك الأخير في هذه المشاركة :-

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

أستاذي الكريم أنا لم أضع في زر الأمر إلا حدث واحد فقط وهو عند النقر Private Sub أمر136_Click() UpdateBooksToLost End Sub Public Sub UpdateBooksToLost() Dim db As DAO.Database Dim rs As DAO.Recordset Dim maxGard As Long Set db = CurrentDb maxGard = Nz(DMax("No_Gard", "T_Gard"), 0) Set rs = db.OpenRecordset("SELECT * FROM [جدول تسجيل الكتب] WHERE [CaseBook] = 'موجود'", dbOpenDynaset) If Not rs.EOF Then rs.MoveFirst Do While Not rs.EOF rs.Edit rs!CaseBook = "فاقد" rs![G N] = maxGard rs.Update rs.MoveNext Loop End If rs.Close Set rs = Nothing Set db = Nothing MsgBox "تم تحديث الكتب إلى الحالة 'فاقد' بنجاح", vbInformation + vbMsgBoxRight, "" End Sub

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

في نفس النموذج أخي :- الموضع الأول :- Private Sub أمر8_Click() Public Function arTableName() As String arTableName = ChrW(1580) & ChrW(1583) & ChrW(1608) & ChrW(1604) & ChrW(32) & _ ChrW(1578) & ChrW(1587) & ChrW(1580) & ChrW(1610) & ChrW(1604) & ChrW(32) & _ ChrW(1575) & ChrW(1604) & ChrW(1603) & ChrW(1578) & ChrW(1576) End Function الموضع الثاني :- Private Sub أمر8_Click() Dim arTblName As String Dim maxGN As Long Dim arMsgPrompt As String Dim arMsgTitle As String Dim msgResponse As VbMsgBoxResult On Error GoTo ErrorHandler arTblName = arTableName maxGN = Nz(DMax("[No_Gard]", "[T_Gard]"), 0) arMsgTitle = "تأكيد تنفيذ الأمر" arMsgPrompt = "أنت على وشك تحديث حالة جميع الكتب باليومية" arMsgPrompt = arMsgPrompt & vbCrLf & "من كتب موجودة إلى كتب فاقد" arMsgPrompt = arMsgPrompt & vbCrLf & "لتأكيد الأمر أضغط موافق ، ولإلغائه أضغط إلغاء" msgResponse = MsgBox(arMsgPrompt, vbQuestion + vbOKCancel + vbMsgBoxRight, arMsgTitle) strSQL = "UPDATE [" & arTblName & "]" & vbCrLf & _ " SET [" & arTblName & "].CaseBook = ""فاقد""," & vbCrLf & _ " [" & arTblName & "].[G N] = " & maxGN & vbCrLf & _ " WHERE ((([" & arTblName & "].CaseBook)=""موجود"")" & vbCrLf & _ " AND (Not ([" & arTblName & "].title) Is Null)" & vbCrLf & _ " AND (([" & arTblName & "].searinumber) Between [forms]![F_GardBooks]![text]" & vbCrLf & _ " AND [forms]![F_GardBooks]![text2]))" & vbCrLf & _ " OR ((([" & arTblName & "].CaseBook)=""موجود"")" & vbCrLf & _ " AND (([" & arTblName & "].title) Is Null)" & vbCrLf & _ " AND (([" & arTblName & "].searinumber) Between [forms]![F_GardBooks]![text]" & vbCrLf & _ " AND [forms]![F_GardBooks]![text2]));" If msgResponse = vbOK Then DoCmd.SetWarnings False DoCmd.RunSQL strSQL DoCmd.SetWarnings True MsgBox "تم تحديث البيانات بنجاح والحمد لله" Else End If Exit Sub ErrorHandler: Debug.Print Err.Number; Err.Description End Sub