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

=COUNTIF(K5:K21;">""")

وبعد ان انتبهت لهذه النقطة هذه فكرتى Dim db As DAO.Database Dim strSQL As String Dim intcomboValue As Integer Dim strcomboValue As String Dim rsCombo As DAO.Recordset ' Open the database Set db = CurrentDb ' Open a recordset for the values in Combo0 Set rsCombo = db.OpenRecordset("SELECT tblSp.id, tblSp.sName, * FROM tblSp;", dbOpenSnapshot) ' Disable the error handling temporarily On Error Resume Next ' Loop through each record in Combo0 Do Until rsCombo.EOF ' Get the value from the current record in Combo0 intcomboValue = rsCombo.Fields("id").Value strcomboValue = rsCombo.Fields("sName").Value ' Construct the SQL update statement strSQL = "UPDATE Table1 " & _ "SET text1 = '" & Nz(strcomboValue, "") & "' " & _ "WHERE Table1.text1 = '" & intcomboValue & "';" ' Execute the query db.Execute strSQL ' Check for errors If Err.Number <> 0 Then ' Clear the error Err.Clear ' Move to the next record without processing the error Resume Next End If ' Move to the next record in Combo0 rsCombo.MoveNext Loop ' Enable the normal error handling On Error GoTo 0 ' Close the recordset and the database rsCombo.Close Set rsCombo = Nothing Set db = Nothing انا اعتبرت مربع السرد غير موجود على النموذج اصلا ووضعت مصدر البيانات فى الكود بديلا عنه Set rsCombo = db.OpenRecordset("SELECT tblSp.id, tblSp.sName, * FROM tblSp;", dbOpenSnapshot) مش عارف ده صح واللا غلط او بالاخص مش عارف انا فاهم واللا مش فاهم انت عارف فهمى على اد حالى ثغنون DatabaseUp2.rar

محاولة منى، مع وجود طريقة أخرى باستخدام حماية الخلايا ولكنها تحتاج عناية كبيرة، هذه أعتقد تفي بالغرض. ظهر لي خلل فجأة ثم حاولت في حدوثه مرة أخرى لمعرفة السبب وحل المشكلة ولكنه اختفى!!. حضور وإنصراف_04.xlsb

تفضل عد البيانات فقط وعدم عد المعادلات.xlsm

يمكن عمل ذلك من خلال استخدام الربط المتأخر (Late Binding) أو الربط المتقدم (Early Binding) وهذا يعتمد على الاحتياجات الخاصة بالتطبيق الذي تقوم بتطويره وعلى الاعتبارات التي ترغب في مراعاتها الربط المتأخر (Late Binding): المرونة: يوفر المزيد من المرونة في حال تحتاج إلى تشغيل التطبيق على إصدارات مختلفة من تطبيق Microsoft Office دون الحاجة إلى إعادة كتابة الشيفرة لا يتطلب تحديد مراجع (References) محددة والتى تختلف تبعا لاختلاف اصدار الأكسس التوافق: يسمح بالتوافق مع تطبيقات Office على أنظمة التشغيل المختلفة بشكل أفضل التحقق من وجود الكائنات: يتطلب التحقق اليدوي من وجود الكائنات أو استخدام الكائنات بدون تحقق مسبق الربط المتقدم (Early Binding): الأداء: قد يكون الربط المتقدم أسرع من الربط المتأخر لأنه يتم تحديد الكائنات في وقت التصميم وليس في وقت التشغيل التحقق التلقائي: يتيح لك IntelliSense والتحقق التلقائي في وقت الكتابة، مما يسهل استكشاف واستخدام الكائنات المتاحة الوثائق والدعم: يوفر تحديد مراجع VBA معلومات وثائق أفضل ودعمًا تلقائيًا للأوامر والخصائص الختام: إذا كنت بحاجة إلى أقصى قدر من المرونة والتوافق وليس لديك اهتمام بالتحقق التلقائي والأداء الأقصي يمكنك استخدام الربط المتأخر إذا كان الأداء والتحقق التلقائي والوثائق المفصلة هي الأمور الرئيسية قطعا سوف تفضل استخدام الربط المتقدم عند استخدام الربط المتقدم يجب أن تأخذ في اعتبارك أن توفر ملفات التعريف (المراجع) قد تتغير مع إصدارات مختلفة من تطبيقات Office لذا يجب عليك تحديثها بناءً على الإصدار الذي يتم استخدامه طيب بالنسبة لى سوف افضل الربط المتقدم (Early Binding) اسباب التفضيل : يهمنى الأداء والمرونة والسرعة وان شاء الله اقدم لكم افكار عبقرية تقدم الاستفادة القصوى دون اى عناء فى المستقبل حيث تمكنت من معالجة السلبيات ان وجدت وهى كالاتى المكتبات - تم علاج مشكلة المكتبات فى هذا الموضوع : library reference: حفظ واسترجاع المكتبات المستخدمة( وداعا لفقد المكتبات بعد اليوم ) - علاج مشكلة اعادة كتابة الاكواد مرارا وتكرارا باستخدام موديول ذكى ولماح وشاطر طيب اولا اسم الموديول : basFileUtilityKit المرجع الذى يجب التأكد من اضافته : Microsoft Office 16.0 Object Library طبعا الرقم 16.0 قد يكون 14.0 أو ....... الخ يختلف تبعا لاصدار الاكسس تم استخدام Enumerated لاضفاء المرونة هو نوع بيانات يتكون من مجموعة من القيم المسماة تسمى العناصر أو الأعضاء أو التعداد أو التعداد من النوع أسماء العداد عادة ما تكون معرفات تتصرف كثوابت في لغة البرمجه يمكن أن يُنظر إلى النوع الذي تم تعداده باعتباره اتحادًا مميزًا من نوع الوحدة الدوال داخل الموديول كالاتى ' Enumeration for the types of file dialogs Enum EnumFileDialogType msoFileDialogFilePicker = 1 msoFileDialogFolderPicker = 4 End Enum ' Enumeration for different file extensions Enum EnumFileExtensions AllFiles TextFiles ExcelFiles ImageFiles VideoFiles AudioFiles PDFFiles WordFiles ' You can add additional file extensions as needed here End Enum ' Enumeration for different options related to file paths Enum EnumOptionFile FilePathWithFileName = 1 FilePathWithoutFileName = 2 FileNameWithExtension = 3 FileNameWithoutExtension = 4 FileExtensionOnly = 5 End Enum Public ChosenFilePaths() As String Dim TempChosenFilePaths() As String ' Check if the Microsoft Office Object Library is referenced ' Make sure to go to Tools > References and select the appropriate version ' e.g., "Microsoft Office 16.0 Object Library" for Office 2016 ' Function to open the file dialog and return the selected file paths Function GetFileDialog(Optional ByVal EnumFileExtension As EnumFileExtensions = AllFiles, Optional ByVal AllowMultipleFiles As Boolean = False) As Variant Dim i As Integer Dim fileDialogObject As Object Dim FilePaths() As String ' Use TempChosenFilePaths as a temporary storage ReDim TempChosenFilePaths(1 To 1) Set fileDialogObject = Application.FileDialog(EnumFileDialogType.msoFileDialogFilePicker) With fileDialogObject .Title = "Select File" .AllowMultiSelect = AllowMultipleFiles .Filters.Clear ' Adding filters based on the selected file extension Select Case EnumFileExtension Case EnumFileExtensions.AllFiles .Filters.Add "All Files", "*.*" Case EnumFileExtensions.TextFiles .Filters.Add "Text Files", "*.txt" Case EnumFileExtensions.ExcelFiles .Filters.Add "Excel Files", "*.xlsx; *.xls" Case EnumFileExtensions.ImageFiles .Filters.Add "Image Files", "*.jpg; *.jpeg; *.png; *.gif" Case EnumFileExtensions.VideoFiles .Filters.Add "Video Files", "*.mp4; *.avi; *.mov" Case EnumFileExtensions.AudioFiles .Filters.Add "Audio Files", "*.mp3; *.wav; *.ogg" Case EnumFileExtensions.PDFFiles .Filters.Add "PDF Files", "*.pdf" Case EnumFileExtensions.WordFiles .Filters.Add "Word Files", "*.docx; *.doc" ' You can add additional file extensions as needed here End Select If .Show = -1 Then ' ReDim the array to the number of selected items ReDim FilePaths(1 To .SelectedItems.Count) ' Populate the array with selected item paths For i = 1 To .SelectedItems.Count FilePaths(i) = .SelectedItems(i) ' Add to TempChosenFilePaths TempChosenFilePaths(UBound(TempChosenFilePaths)) = FilePaths(i) ReDim Preserve TempChosenFilePaths(1 To UBound(TempChosenFilePaths) + 1) Next i ' Return the array GetFileDialog = JoinFilePaths(FilePaths) ' Update ChosenFilePaths with the temporary values ChosenFilePaths = TempChosenFilePaths ' Clear TempChosenFilePaths Erase TempChosenFilePaths Else ' Return an empty string if no file is selected GetFileDialog = "" End If End With ' Set file dialog object to nothing Set fileDialogObject = Nothing End Function ' Function to join paths and set them to the global variable Function JoinFilePaths(paths() As String) As String JoinFilePaths = Join(paths, vbCrLf) End Function ' Function to check if ListBox contains a specific item Function ListBoxContainsItem(listBox As Object, item As String) As Boolean Dim i As Integer ListBoxContainsItem = False For i = 0 To listBox.ListCount - 1 If listBox.Column(0, i) = item Then ListBoxContainsItem = True Exit Function End If Next i End Function ' Subroutine to add paths to ListBox in the form Sub AddToFormListBox(frm As Object, paths() As String, ListBoxName As String, Optional ClearListBox As Boolean = True) Dim i As Integer Dim listBoxControl As Object ' Check if frm is not Nothing If Not frm Is Nothing Then ' Check if ListBox with the specified name exists in the form's controls On Error Resume Next Set listBoxControl = frm.Controls(ListBoxName) On Error GoTo 0 ' If ListBox control exists, add or clear items If Not listBoxControl Is Nothing Then ' Clear ListBox if ClearListBox is True If ClearListBox Then listBoxControl.RowSource = "" End If ' Add unique non-empty items to ListBox For i = LBound(paths) To UBound(paths) If Trim(paths(i)) <> "" And Not ListBoxContainsItem(listBoxControl, paths(i)) Then listBoxControl.AddItem paths(i) End If Next i Else ' Handle the case where ListBox control does not exist MsgBox "ListBox with name '" & ListBoxName & "' not found in the form.", vbExclamation End If End If End Sub ' Subroutine to add paths to Access table Sub AddToAccessTable(tableName As String, paths() As String) Dim db As DAO.Database Dim rs As DAO.Recordset Dim i As Integer Dim filePath As String ' Open the database Set db = CurrentDb ' Open the table Set rs = db.OpenRecordset(tableName, dbOpenDynaset) ' Add each non-empty and non-duplicate path to the table For i = LBound(paths) To UBound(paths) filePath = Trim(paths(i)) ' Check if the path does not already exist in the table If filePath <> "" And DCount("*", tableName, "FilePath='" & filePath & "'") = 0 Then rs.AddNew rs.Fields("FilePath").Value = filePath rs.Update End If Next i ' Close the recordset and database rs.Close Set rs = Nothing Set db = Nothing End Sub ' Function to open the folder dialog and return the selected folder path Function GetFolderDialog() As String Dim folderDialogObject As Object Set folderDialogObject = Application.FileDialog(EnumFileDialogType.msoFileDialogFolderPicker) With folderDialogObject .Title = "Select Folder" .AllowMultiSelect = False .Show End With If folderDialogObject.SelectedItems.Count > 0 Then GetFolderDialog = folderDialogObject.SelectedItems(1) Else ' Handle the case where no folder is selected MsgBox "No folder selected.", vbExclamation GetFolderDialog = "" End If Set folderDialogObject = Nothing End Function ' Function to get the desired option for a file path Function GetFileOption(ByRef filePath As String, Optional ByRef EnumOptionFile As EnumOptionFile = FilePathWithFileName) As String ' Check if the file exists If FileExists(filePath) Then ' Get file File Option using GetFileOption function Select Case EnumOptionFile Case FilePathWithoutFileName GetFileOption = Left(filePath, InStrRev(filePath, "\")) Case FilePathWithFileName GetFileOption = filePath Case FileNameWithExtension GetFileOption = Mid(filePath, InStrRev(filePath, "\") + 1) Case FileExtensionOnly GetFileOption = Right(filePath, Len(filePath) - InStrRev(filePath, ".")) Case FileNameWithoutExtension GetFileOption = Mid(filePath, InStrRev(filePath, "\") + 1, InStrRev(filePath, ".") - InStrRev(filePath, "\") - 1) End Select Else ' Return an empty string if the file does not exist GetFileOption = "" End If End Function ' Function to get additional information about a file Function GetFileInfo(filePath As String) As String ' Check if the file exists If FileExists(filePath) Then ' Get file information using GetFileInfo function Dim fileInfo As String fileInfo = "File Information:" & vbCrLf fileInfo = fileInfo & "Path: " & filePath & vbCrLf fileInfo = fileInfo & "Size: " & FileLen(filePath) & " bytes" & vbCrLf fileInfo = fileInfo & "Created: " & FileDateTime(filePath) & vbCrLf GetFileInfo = fileInfo Else ' Return an empty string if the file does not exist GetFileInfo = "" End If End Function ' Function to create a new folder Function CreateNewFolder(parentPath As String, folderName As String) As String Dim newFolderPath As String newFolderPath = parentPath & "\" & folderName MkDir newFolderPath CreateNewFolder = newFolderPath End Function ' Function to check if a file exists Function FileExists(ByVal filePath As String, Optional findFolders As Boolean = False) As Boolean Const vbReadOnly As Long = 1 Const vbHidden As Long = 2 Const vbSystem As Long = 4 Const vbDirectory As Long = 16 Dim attributes As Long attributes = (vbReadOnly Or vbHidden Or vbSystem) If findFolders Then attributes = (attributes Or vbDirectory) ' Include folders as well. Else ' Strip any trailing slash, so Dir does not look inside the folder. Do While Right(filePath, 1) = "\" filePath = Left(filePath, Len(filePath) - 1) Loop End If ' If Dir() returns something, the file exists. FileExists = (Len(Dir(filePath, attributes)) > 0) End Function من خلال تلك الوحدة النمطية يمكن عمل الاتى 1- انتقاء مسار مجلد من خلال الدالة : GetFolderDialog الاستدعاء: GetFolderDialog 2- انتقاء مسار ملف / ملفات من خلال الدالة : GetFileDialog الاستدعاء:GetFileDialog(EnumFileExtensions, AllowMultipleFiles) -قائمة EnumFileExtensions التى تضفى مرونة فى تحديد نوع الملفات التى تريد انتقائها - AllowMultipleFiles تحديد ما اذا كنت تريد انتقاء ملف واحد فقط لتكون False , أو ملفات متعددة لتكون True 3-استخلاص معلومات الملف من خلال الدالة : GetFileInfo الاستدعاء:GetFileInfo(filePath) 4- التحكم فى خيارات الملف / الملفات من خلال الدالة : GetFileOption وهى (المسار كاملا مع اسم الملف , مسار الملف فقط , اسم الملف مع الامتداد فقط , امتداد الملف فقط ) الاستدعاء:GetFileOption(filePath , EnumOptionFile) 5- اضافة مسار الملف / الملفات الذى يتم انتقاءه كاملا او حسب ما تريد من الخطوة الرابعة السابقة الى مربع قائمة وذلك من خلال الدالة : AddToFormListBox الاستدعاء: 6- اضافة مسار الملف / الملفات الذى يتم انتقاءه كاملا او حسب ما تريد من الخطوة الرابعة الى جدول من خلال الدالة: AddToAccessTable الاستدعاء: يتبع...... FileDialog.accdb

نعم هو كذا .. تسلم الأنامل التي سطرت هذا الابداع الف شكر استاذنا .. هذا الكود هو حجر الاساس .. سوف اطوره ليشمل جميع مربعات التحرير داخل النموذج لن استغني عن مساعدتك ولمساتك ان احتجت لذلك .

العفو منكم استاذى الجليل ومعلمى القدير طيب ممكن نعمل الكود الثانى بالشكل الاتى ليتم التحديث على الجميع جملة مرة واحدة وبدون اختيار اى قيمة من مربع التحرير ولكن سوف يكون ذلك التحديث بالاعتماد على القيم من مربع السرد مهما كان مصدر بياناته Dim db As DAO.Database Dim strSQL As String Dim intcomboValue As Integer Dim strcomboValue As String Dim rsCombo As DAO.Recordset ' Open the database Set db = CurrentDb ' Open a recordset for the values in Combo0 Set rsCombo = db.OpenRecordset(Me.Combo0.RowSource, dbOpenSnapshot) ' Disable the error handling temporarily On Error Resume Next ' Loop through each record in Combo0 Do Until rsCombo.EOF ' Get the value from the current record in Combo0 intcomboValue = rsCombo.Fields("id").Value strcomboValue = rsCombo.Fields("sName").Value ' Construct the SQL update statement strSQL = "UPDATE Table1 " & _ "SET text1 = '" & Nz(strcomboValue, "") & "' " & _ "WHERE Table1.text1 = '" & intcomboValue & "';" ' Execute the query db.Execute strSQL ' Check for errors If Err.Number <> 0 Then ' Clear the error Err.Clear ' Move to the next record without processing the error Resume Next End If ' Move to the next record in Combo0 rsCombo.MoveNext Loop ' Enable the normal error handling On Error GoTo 0 ' Close the recordset and the database rsCombo.Close Set rsCombo = Nothing Set db = Nothing الان الاعتماد على مربع السرد مهما كان مصدر بياناته من خلال السطر Set rsCombo = db.OpenRecordset(Me.Combo0.RowSource, dbOpenSnapshot)

لا ابدا ... انا شدتني هذه العبارة .... دائم اسلوبك جذاب كاخلاقك النبيلة ونقاء قلبك بارك الله فيك اخي الكريم محمد .. ونتعلم منك الاخلاق الكريمة ...

الف الف شكر على مجهودك ووقتك

وعليكم السلام ورحمة الله وبركاته: مناداة 3.xls

تستاهل اكثر من هذا المبلغ ههههههه استاذي الكريم بارك الله فيك

نسيت اقول اني حولت مربع التسمية الى مربع نص .... تفضل ملفك بعد التعديل ... 20231220.mdb لاحظ اتعاب المحاسب .... ههههههه

تم إصلاح الخلل وعمل عدة تنقيحات: حضور وإنصراف_05.xlsb

هههههه ..... طيب بالنسبة للطلب ... انظر الصور وطبق لديك ....

الاخوه الأعزاء الجدول 01 فيه معادله VLOOKUP المشكلة اذا اردت عد الخلايا التي تحتوي على الجنسية يقوم بعدها مع المعادله ارجو حل هذه المشكلة مع تلوين الخلايا التي تحتوي على أي جنسية كما في الجدول 02 ولكم وافر الامتنان عد البيانات فقط وعدم عد المعادلات.xlsm

اكتب الفكرة هنا ليستفيد منها غيرك ممن يمر على هذا الموضوع

هل المطلوب 30000 ام تريدها 30000- لان الناتج سالب في عمليتك الحسابية فهل العملية صحيحة وتريد الرقم موجب فقط ؟؟؟

شكرا للجميع

حباً وكرامة تفضل أخي الكريم لك ما طلبت على الرحب والسعة ضريبة رواتب و اجور.xlsx

تفضل أخي @iyad mohamad حسب فهمي . برنامج أستاذتنا زهرة العبدالله ووافني بالرد . تغير النموذج يمين يسار.rar

إذن في حالة الغياب ستبدل "P" بحرف "A" مثلا؟ اقتراحي لا داعي لكتابة "P" للحضور، ولا "V" لعطلة نهاية الأسبوع. أنت تحتاج فقط: كتابة "A" من Absent في حالة الغياب فقط. وكتابة "V" من Vacation في حالة كونه في إجازة. أما عطلة نهاية الأسبوع لا تحتاج إلى كتابة، وعند الرغبة فليكن حرفها "W" من Weekend. ويمكن التحكم عند الكتابة بمنع الإدخال في خانة عطلة نهاية الأسبوع كذلك ومنع إدخال غير الحروف المطلوبة. سؤال آخل ماذا لو عمل الموظف أيام العطل الأسبوعية، هل ستضع له حرفا جديدا أم ستستخدم حرف "P" أيضا؟

أعرف سؤالي قد يكون تطفلا، وما دفعني للسؤال لغرابة الطلب، أنا توقعت ستملأ الخلايا ببيانات متغيرة وليست ثابتة كـ "V" و "P". ربما لو توضح لنا الهدف اختصرنا لك كل هالتصميم والكود بدالة صغيرة من خمسة سطور تعطيك المعلومة المطلوبة بسهولة.

سقط سهوا .... 20231220.mdb

بعد ادن الاخ @AbuuAhmed اليك حل اخر على حسب الشروط المدكورة والصورة المرفقة في في اول مشاركة Sub Color_Friday() Dim lastCol&, LastRow&, i&, j&, lr&, Search As String Dim WS As Worksheet: Set WS = ThisWorkbook.Worksheets("Base") Search = "الجمعة" Application.ScreenUpdating = False With WS lr = .Columns("A:B").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row lastCol = .Cells(5, WS.Columns.Count).End(xlToLeft).Column LastRow = .Range("B" & .Rows.Count).End(xlUp).Row WS.Range("D5:AH" & lr).Interior.ColorIndex = xlNone .Range(Cells(5, 4), Cells(6, lastCol - 4)).Interior.Color = RGB(217, 217, 217) If lr > 6 Then .Range(Cells(7, 4), Cells(lr, lastCol - 4)).ClearContents End If For j = 7 To LastRow If .Cells(j, 2) <> "" Then .Range(Cells(7, 4), Cells(LastRow, lastCol - 4)).Value = "V" End If For i = 4 To lastCol If WS.Cells(5, i).Value2 Like Search Then .Range(Cells(7, i).Address, Cells(LastRow, i).Address).Value = "P" .Range(Cells(5, i).Address, Cells(LastRow, i).Address).Interior.ColorIndex = 40 End If Next Next End With Application.ScreenUpdating = True End Sub حضور 2وإنصراف.xlsb

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

هى طبعا الفكرة حلوة بس...... فعلا فى الوقت الراهن لا املك الادوات اللازمة ولا رفاهية الوقت اننى دائما اضع نصب عينى عند تطبيق الفكرة بقدر الامكان تحقيق المتطلبات الاتيه 1- ان تكون عامة بقدر الامكان بحيث يسهل استخدامها فى جميع المجالات والحلات وفق الرغبات دون اى قيود قدر الامكان ليسهل 2- المرونة بحيث تتم كتابة الكود مرة واحدة وقد يكون وقت كتابته بذل الجهد فى الافكار كبير والعناء فى التنفيذ اكبر وقت تطويع الكود لتفيذ الفكرة ولكن قمة المتعة فى سهولة الاستدعاء مستقبلا ويعلم الله لما تم بذل الوقت والجهد وكان الحصاد بتلك المرونة والسهولة خطر على بالى مشاركة اخوانى واحبابى هذه الافكار التى تسهل عليهم مستقبلا الكثير من الوقت فى كتابة الاكواد وتقديم الحلول المرنة لحصاد النتائج المبهرة دون اى عناء يذكر

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