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

انظر الاستعلام SALESQT قمت بحذف الحقلين وممكن تستخدم عبارة تعبير Expression كما في الصورة

اللي يدخل مع مبرمجين في : ( لو ) و ( إذا ) حيودوه في ستين سكة .. الله يعينه 🤣 صحيح انتم شعبتوها .. سكك وطرق المسألة كلها سجلات ثابتة كل سجل له آي دي خاص ثابت ثبات الى الممات هذه السجلات غير قابلة للحذف .. صباح / مساء / دوام كامل / دوام خاص المتغير فيها هو حقول الوقت فقط .. فيمكن تغيير وقت الدخول او الخروج حسب الحاجة ، وبناء عليه سيتغير عدد الساعات هذا كل شي .

ايه الحلاوة دى الله عليك بجد فعلا الفكرة ولا اروع وعلشان عجبتنى الفكرة كتبت لها هذا الكود الذى يقوم بانشاء الجدول وملئ البيانات وانشاء الاستعلام بشكل آلى وديناميكى بدون ادنى جهد وطبعا لم انسى الاخذ فى الحسبان اضفاء المرونة التامة بالتحكم فى كل كبيرة صغيرة الكود Option Compare Database Option Explicit '' === ثوابت عامة لإعدادات توليد التواريخ === Public Const TABLE_NAME As String = "tblCalendarComponents" Private Const QUERY_NAME As String = "qryGenerateFullDates" Public Const DATE_TYPE_DAY As String = "DayType" Public Const DATE_TYPE_MONTH As String = "MonthType" Public Const DATE_TYPE_YEAR As String = "YearType" Public Const DefaultYearOffset As Long = 3 Public Const DefaultStartYear As Long = 0 Public Const DefaultYearCount As Long = 100 Public Const MIN_YEAR As Long = 1900 Public Const MAX_YEAR As Long = 2100 '' === TestGenerateDates Public Sub TestGenerateDates() ''--- سنة البدء (0 = القيمة الافتراضية) Dim lngStartYear As Long: lngStartYear = 0 ''--- فرق السنوات الافتراضي Dim lngOffset As Long: lngOffset = DefaultYearOffset ''--- عدد السنوات المراد توليدها Dim lngYearCount As Long: lngYearCount = 10 Call GenerateDates(lngStartYear, lngOffset, lngYearCount) End Sub '' ======= الإجراء الرئيسي لإنشاء الجدول والاستعلام ======= Public Sub GenerateDates( _ Optional ByVal StartYear As Long = 0, _ Optional ByVal YearOffset As Long = DefaultYearOffset, _ Optional ByVal YearCount As Long = DefaultYearCount) On Error GoTo ErrorHandler ' تعيين الفرق الافتراضي إن لم يُمرر If YearOffset = -1 Then YearOffset = DefaultYearOffset ' حساب سنة البدء إذا لم تُمرر If StartYear = 0 Then StartYear = Year(Date) - YearOffset ' التحقق من سنة البدء ضمن النطاق If StartYear < MIN_YEAR Or StartYear > MAX_YEAR Then Err.Raise vbObjectError + 1000, , "StartYear يجب أن يكون بين " & MIN_YEAR & " و " & MAX_YEAR End If ' التحقق من عدد السنوات ضمن النطاق If YearCount < 1 Or YearCount > (MAX_YEAR - StartYear + 1) Then Err.Raise vbObjectError + 1001, , "YearCount يجب أن يكون بين 1 و " & (MAX_YEAR - StartYear + 1) End If ' إنشاء الجدول والاستعلام Call PopulateDateTable(StartYear, YearCount) Call CreateOrUpdateDateGenerationQuery MsgBox "تم إنشاء الجدول والاستعلام بنجاح.", vbInformation, "نجاح العملية" Exit Sub ErrorHandler: MsgBox "حدث خطأ أثناء إنشاء الجدول أو الاستعلام:" & vbCrLf & _ "رقم الخطأ: " & Err.Number & vbCrLf & _ "الوصف: " & Err.Description, vbCritical, "خطأ" End Sub '' ======= ملء جدول التواريخ ======= Public Sub PopulateDateTable( _ Optional ByVal StartYear As Long = DefaultStartYear, _ Optional ByVal YearCount As Long = DefaultYearCount) On Error GoTo ErrorHandler Dim db As DAO.Database: Set db = CurrentDb ' حذف الجدول قبل الإنشاء On Error Resume Next db.TableDefs.Delete TABLE_NAME On Error GoTo ErrorHandler Call CreateDateTable(db) If StartYear = 0 Then StartYear = Year(Date) - DefaultYearOffset Dim i As Long For i = 1 To 31 db.Execute "INSERT INTO " & TABLE_NAME & " (DateNo, DateType) VALUES (" & i & ", '" & DATE_TYPE_DAY & "')", dbFailOnError Next i For i = 1 To 12 db.Execute "INSERT INTO " & TABLE_NAME & " (DateNo, DateType) VALUES (" & i & ", '" & DATE_TYPE_MONTH & "')", dbFailOnError Next i For i = 0 To YearCount - 1 db.Execute "INSERT INTO " & TABLE_NAME & " (DateNo, DateType) VALUES (" & StartYear + i & ", '" & DATE_TYPE_YEAR & "')", dbFailOnError Next i Set db = Nothing Exit Sub ErrorHandler: MsgBox " خطأ أثناء تعبئة الجدول: " & Err.Description, vbCritical End Sub '' ==== دالة لحساب الحد الأقصى لطول النص بين أنواع التاريخ Public Function GetMaxDateTypeLength() As Long Dim lngMaxLen As Long lngMaxLen = Len(DATE_TYPE_DAY) If Len(DATE_TYPE_MONTH) > lngMaxLen Then lngMaxLen = Len(DATE_TYPE_MONTH) If Len(DATE_TYPE_YEAR) > lngMaxLen Then lngMaxLen = Len(DATE_TYPE_YEAR) GetMaxDateTypeLength = lngMaxLen End Function '' ======= إنشاء الجدول مع الحقول والفهرسة ======= Private Sub CreateDateTable(db As DAO.Database) On Error Resume Next db.TableDefs.Delete TABLE_NAME On Error GoTo 0 Dim tdf As DAO.TableDef Set tdf = db.CreateTableDef(TABLE_NAME) With tdf '' حقل الترقيم التلقائي Dim fld As DAO.Field Set fld = .CreateField("ID", dbLong) fld.Attributes = dbAutoIncrField .Fields.Append fld '' حقل الرقم Set fld = .CreateField("DateNo", dbLong) fld.Required = True .Fields.Append fld '' نوع التاريخ Set fld = .CreateField("DateType", dbText, GetMaxDateTypeLength()) fld.Required = True .Fields.Append fld End With '' فهرس المفتاح الأساسي Dim idx As DAO.Index Set idx = tdf.CreateIndex("PrimaryKey") idx.Primary = True idx.Fields.Append idx.CreateField("ID") tdf.Indexes.Append idx '' فهرس فريد على التاريخ والنوع Set idx = tdf.CreateIndex("UniqueDateNoType") idx.Unique = True idx.Fields.Append idx.CreateField("DateNo") idx.Fields.Append idx.CreateField("DateType") tdf.Indexes.Append idx db.TableDefs.Append tdf Set fld = Nothing Set idx = Nothing Set tdf = Nothing End Sub '' ======= إنشاء أو تحديث الاستعلام لإنتاج كل التواريخ ======= Public Sub CreateOrUpdateDateGenerationQuery() On Error GoTo ErrorHandler Dim db As DAO.Database: Set db = CurrentDb Dim strSQL As String Dim qdf As DAO.QueryDef strSQL = "SELECT DateSerial(Years.DateNo, Months.DateNo, Days.DateNo) AS GeneratedDate " & _ "FROM " & TABLE_NAME & " AS Days, " & _ TABLE_NAME & " AS Months, " & _ TABLE_NAME & " AS Years " & _ "WHERE Days.DateType = '" & DATE_TYPE_DAY & "' " & _ "AND Months.DateType = '" & DATE_TYPE_MONTH & "' " & _ "AND Years.DateType = '" & DATE_TYPE_YEAR & "'" '' حذف الاستعلام لو موجود If QueryExists(QUERY_NAME) Then db.QueryDefs.Delete QUERY_NAME End If '' إنشاء الاستعلام Set qdf = db.CreateQueryDef(QUERY_NAME, strSQL) Application.RefreshDatabaseWindow Exit Sub ErrorHandler: MsgBox " خطأ أثناء إنشاء الاستعلام: " & Err.Description, vbCritical End Sub '' ======= التحقق من وجود جدول ======= Private Function TableExists(ByVal TableName As String) As Boolean On Error Resume Next TableExists = (Len(CurrentDb.TableDefs(TableName).Name) > 0) On Error GoTo 0 End Function '' ======= التحقق من وجود استعلام ======= Private Function QueryExists(ByVal QueryName As String) As Boolean On Error Resume Next QueryExists = (Len(CurrentDb.QueryDefs(QueryName).Name) > 0) On Error GoTo 0 End Function واخيرا يتم تعديل الاعدادت المناسبة لك و فقط يتم عمل كل شئ من تشغيل الإجراء التالى: TestGenerateDates

معذرة لتأخير بالمباركة لأني بكمل عمليات عينيا بمصر مبروك علينا وتمنياتي بالتوفيق دائما

طبعا تم تغيير كبير في الملف وهذا لازم لتقليل حجم الملف ولتطبيق وتنفيذ مطلوبك تم حدف ورقة من الأوراق , ليس لها لزمة تم فك الدمج عن بعض الأسطر والاعمدة والأن قم بتغيير القيمة في الخلية الكحلية (الفصول 1 - 3) حيث أنها تحتوي على قائمة منسدلة واختر التاريخ المطلوب وانظر للنتيجة باقي حاجة أنا نسيت المعادلات في أسفل الورقة ممكت تكتبهم من جديد المشكلة الأن : لو كان عدد الغائبين في الفصل الواحد أكثر من 10 فهذا الحل سيأتي بالعشرة فقط الغياب2.xls

الرجاء إرفاق ملف اكسل يتم الشرح فيه فهذا اسهل في فهم المطلوب

الف شكر ابا جودي .. حفظك الله ورعاك

دالة حساب الوقت اللى كانت فى الوحدة النمطية فى المرفق الاول Public Function HoursAndMinutes(interval As Variant) As String Dim totalMinutes As Long, totalseconds As Long Dim hours As Long, minutes As Long, seconds As Long If IsNull(interval) = True Then Exit Function hours = Int(CSng(interval * 24)) totalMinutes = Int(CSng(interval * 1440)) minutes = totalMinutes Mod 60 HoursAndMinutes = hours & ":" & minutes End Function تقوم بحساب الساعات بشكل منفصل عن الدقائق باستخدام interval * 24 ثم تحسب الدقائق من إجمالي الدقائق وهذا قد يسبب تعارض لا تستخدم Format(minutes, "00") بالتالي قد تظهر النتيجة مثل 5:3 بدلا من 5:03 وجود المتغير totalseconds وseconds بدون استخدام فعلي (زيادة غير مفيدة) منطق مزدوج: سطر يحسب الساعات من معامل معين وسطر يحسب الدقائق من معامل آخر — وهذا قد يسبب أخطاء دقيقة في الحالات الطرفية -------- الدالة الأخيرة بعض التطوير '' ========================================================== '' الدالة: HoursAndMinutes '' الوصف: تحويل قيمة وقت مخزنة كنسبة من اليوم (Date/Time) إلى نص يحتوي على عدد الساعات والدقائق '' المعامل: interval - متغير يمثل مدة زمنية كنسبة من اليوم (مثلاً 0.5 = 12 ساعة) '' الناتج: نص بصيغة "ساعات:دقائق" '' ========================================================== Public Function HoursAndMinutes(interval As Variant) As String Dim lngTotalMinutes As Long Dim lngHours As Long Dim lngMinutes As Long If IsNull(interval) Then Exit Function lngTotalMinutes = Int(CSng(interval * 24 * 60)) ' تحويل إلى عدد الدقائق lngHours = lngTotalMinutes \ 60 ' الساعات الكاملة lngMinutes = lngTotalMinutes Mod 60 ' باقي الدقائق HoursAndMinutes = lngHours & ":" & Format(lngMinutes, "00") ' تنسيق بدقائق صفرية عند الحاجة End Function تقوم بحساب إجمالي الدقائق أولا ثم تفصل منها الساعات والدقائق بدقة تستخدم Format(..., "00") لضمان ظهور الدقائق بصيغة مزدوجة (مثل: 5 → 05) صياغتها أوضح ولا تفقد الدقائق عند الحساب دقيقة في كل الحالات لو أردت دعم الثواني بنفس الأسلوب أقدر أعدل لك الدالة فقط أخبرنى

على فكرة ، ممكن يكون في لبس في فهم ftraName . انا ربطت الموضوع على انه ممكن يكون اسماء الفترات في جدول منفصل وان 1 و 2 دول معرفات الفترات في جدول أسماء الفترات ، وليس الحقل ID اللي في الجدول الحالي tbl_Ftrat .. يعني انا اشتغلت على ان الفترات ليها جدول منفصل وان القيمة ممكن تكون معرف الفترة بناءً على الجملة دي فهمت قصدي !؟

بلاش انا اجيب لك الاسكرين شوت من مرفقك انت عرفت هو شغال ليه لانك غيرت اسم الفترات يا افندم

ما رأيكم بهذه الحيلة على اعتبار ان النموذج تحكم ومعرفات السجلات لن تتغير ابدا .. ولو تم اضافة سجلات جديدة كفترات اضافية لا مشكلة .. Dim i, ii As Date Me.Recordset.FindFirst "id =2 " i = countWorkHours Me.Recordset.FindFirst "id =3 " ii = countWorkHours Me.Recordset.FindFirst "id =1 " countWorkHours = i + ii Database2.rar

لا تكتفى بما لديك كلف نفسك عناء محاولة ايجاد و معرفة الفرق بين Private Sub cmdSave_Click() Dim lngMinutesMorning As Long Dim lngMinutesEvening As Long Dim lngTotalMinutes As Long Dim datResult As Date '' === احسب عدد الدقائق للفترتين lngMinutesMorning = DateDiff("n", #00:00#, DLookup("countWorkHours", "tbl_Ftrat", "id=2")) lngMinutesEvening = DateDiff("n", #00:00#, DLookup("countWorkHours", "tbl_Ftrat", "id=3")) '' === إجمالي عدد الدقائق lngTotalMinutes = lngMinutesMorning + lngMinutesEvening '' === تحويله إلى نسبة يوم Date/Time datResult = lngTotalMinutes / 1440 '' === تحديث السجل للمعرف رقم 1 CurrentDb.Execute "UPDATE tbl_Ftrat SET countWorkHours = #" & Format(datResult, "hh:nn") & "# WHERE id = 1", dbFailOnError countWorkHours.Requery Me.Repaint End Sub وبين الحل الاخير لك Dim totalMinutes As Double totalMinutes = DSum("countWorkHours", "tbl_Ftrat", "ftraName IN ('1','2') AND ID > 1") CurrentDb.Execute "UPDATE tbl_Ftrat SET countWorkHours = " & totalMinutes & " WHERE ID = 1", dbFailOnError Me.Refresh

أنا سأكتفي بما لدي في آخر محاولة ,, في الزر :- Dim totalminutes As Double totalminutes = Nz(DSum("countWorkHours", "tbl_Ftrat", "ftraName IN ('1','2') AND ID > 1"), 0) CurrentDb.Execute "UPDATE tbl_Ftrat SET countWorkHours = " & totalminutes & " WHERE ID = 1", dbFailOnError Me.Refresh الملف المرفق :- Database2.zip

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

بغض النظر عن الخطأ الذي ذكره أبو جودي ، ومن المؤكد أن السجلات هي للتجربة فقط لا غير .. في الدالة العامة التالية :- Public Sub UpdateRecordWithID(frm As Form, idField As String, idValue As Variant, targetField As String, sumField As String) Dim rs As DAO.Recordset Dim total As Double Dim foundTarget As Boolean Set rs = frm.RecordsetClone rs.MoveFirst Do Until rs.EOF If foundTarget Then If rs!ftraName = "فترة صباحية" Or rs!ftraName = "فترة مسائية" Then total = total + Nz(rs.Fields(sumField).Value, 0) End If ElseIf rs.Fields(idField).Value = idValue Then foundTarget = True End If rs.MoveNext Loop If Not foundTarget Then rs.Close: Set rs = Nothing Exit Sub End If rs.MoveFirst Do Until rs.EOF If rs.Fields(idField).Value = idValue Then frm.Recordset.Bookmark = rs.Bookmark frm.Controls(targetField).Value = total frm.Dirty = False Exit Do End If rs.MoveNext Loop rs.Close: Set rs = Nothing End Sub تركت لك حرية تحديد اسم الحقل الفريد ورقمه ، واسم الحقل المستهدف تحديثه بالقيم التي تريدها من خلال الاستدعاء كالآتي :- Call UpdateRecordWithID(Me, "ID", 1, "countWorkHours", "countWorkHours") الملف مع الفكرة المقترحة :- Database1.zip

كما تشاهد في الصورة : الحقل الأول الأعلى فارغ .. الخاص بالفترتين ... لأن السجل مجرد مسمى ليس امامه وقت دخول ولا خروج اريد ان يتم ادراج قيمة في هذا الحقل هذه القيمة = مجموع ساعات العمل : المسائية + الصباحية بحيث تصبح القيمة= 09:40

الف لا بأس عليك أستاذنا خليفة . ونسأل الله لك الشفاء العاجل القريب . إن ربك لهو المُجيب .. الله يبارك فيك 💐

وبسبب هذه الجملة اعيد صياغة الكود فى الوحدة النمطية العامة ليكون بهذا الشكل لاضافة قاموس لدعم اللغات المتعددة واضافة الاختصارات او الخطاء الشائعة او الممكنة فى المستقبل Public Function GetTimePeriod(ByVal varDateTime As Variant) As String On Error GoTo ErrHandler Const STR_MORNING As String = "الصباح" Const STR_EVENING As String = "المساء" If IsMissing(varDateTime) Or IsNull(varDateTime) Then Exit Function If Len(Trim(Nz(varDateTime, ""))) = 0 Then Exit Function Dim strInput As String strInput = Trim(CStr(Nz(varDateTime, ""))) ' استبدال التعابير المحلية أو الأجنبية بـ AM/PM Dim dicReplacements As Object Set dicReplacements = CreateObject("Scripting.Dictionary") With dicReplacements ' العربية .Add "ص", "AM" .Add "ص.", "AM" .Add "صباح", "AM" .Add "صباحا", "AM" .Add "صباحًا", "AM" .Add "صـ", "AM" .Add "صـباح", "AM" .Add "صباحاً", "AM" .Add "م", "PM" .Add "م.", "PM" .Add "مساء", "PM" .Add "مساءً", "PM" .Add "مسائا", "PM" .Add "مساءاً", "PM" .Add "مسائياً", "PM" ' الفرنسية .Add "matin", "AM" .Add "du matin", "AM" .Add "soir", "PM" .Add "du soir", "PM" .Add "après-midi", "PM" ' الألمانية .Add "vormittag", "AM" ' قبل الظهر .Add "morgen", "AM" ' الصباح .Add "morgens", "AM" ' في الصباح .Add "nachmittag", "PM" ' بعد الظهر .Add "abend", "PM" ' المساء .Add "abends", "PM" ' في المساء .Add "nachts", "PM" ' ليلًا ' الإنجليزية - دعم إضافي لأنماط مكررة .Add "am", "AM" .Add "pm", "PM" .Add "a.m.", "AM" .Add "p.m.", "PM" .Add "a.m", "AM" .Add "p.m", "PM" .Add "A.M.", "AM" .Add "P.M.", "PM" .Add "A.M", "AM" .Add "P.M", "PM" End With Dim varKey As Variant For Each varKey In dicReplacements.Keys strInput = Replace(strInput, varKey, dicReplacements(varKey), , , vbTextCompare) Next varKey ' تنسيق الوقت (دمج من FixTimeFormat) Dim strSuffix As String Dim strTimeOnly As String Dim arrParts() As String If InStr(1, strInput, "AM", vbTextCompare) > 0 Then strSuffix = " AM" strTimeOnly = Replace(strInput, "AM", "", , , vbTextCompare) ElseIf InStr(1, strInput, "PM", vbTextCompare) > 0 Then strSuffix = " PM" strTimeOnly = Replace(strInput, "PM", "", , , vbTextCompare) Else strSuffix = "" strTimeOnly = strInput End If strTimeOnly = Trim(strTimeOnly) arrParts = Split(strTimeOnly, ":") If UBound(arrParts) >= 0 Then arrParts(0) = Format$(Val(arrParts(0)), "00") End If If UBound(arrParts) >= 1 Then arrParts(1) = Format$(Val(arrParts(1)), "00") Else ReDim Preserve arrParts(1) arrParts(1) = "00" End If strInput = Join(arrParts, ":") & strSuffix ' التحويل إلى وقت فعلي Dim dtmTime As Date dtmTime = CDate(strInput) Dim lngHour As Long lngHour = Hour(dtmTime) If lngHour < 12 Then GetTimePeriod = STR_MORNING Else GetTimePeriod = STR_EVENING End If Exit Function ErrHandler: GetTimePeriod = "" End Function

تفضل ...... EL-DATA- T.rar

دالة InStr من أهم وأقوى الدوال المستخدمة في التعامل مع السلاسل النصية تستخدم لتحديد موضع أول ظهور لسلسلة فرعية داخل سلسلة نصية أخرى يمكن الاعتماد عليها في التحقق من وجود رموز أو مقاطع نصية داخل محتوى مثل: التحقق من وجود امتداد ملف البحث عن كلمة في اسم ملف فحص تنسيقات أو كجزء من معالجة متقدمة للنصوص الشكل العام: InStr(Start, String1, String2 , Compare) شرح المعاملات: Start (اختياري): >>---> رقم الموضع الذي تبدأ منه عملية البحث في String1 (يبدأ من 1) String1: >>---> السلسلة الأساسية التي يتم البحث بداخلها String2: >>---> السلسلة الفرعية المطلوب العثور عليها Compare (اختياري): >>---> نوع المقارنة يمكن استخدام: vbBinaryCompare (افتراضي): مقارنة حساسة لحالة الأحرف vbTextCompare : مقارنة تتجاهل حالة الأحرف الناتج: ترجع الدالة رقم موضع أول تطابق (Starting from 1) أو 0 إذا لم يتم العثور على أي تطابق أمثلة توضيحية شاملة 1- اختبار حالات مختلفة للدالة InStr Dim strText As String Dim strSearch As String Dim intStart As Integer Dim intResult As Integer ' البحث عن أول ظهور للحرف "a" strText = "Mohesam" strSearch = "a" intStart = 1 intResult = InStr(intStart, strText, strSearch) 'M o h e s a m '1 2 3 4 5 6 7 Debug.Print "الحالة 1: InStr(" & intStart & ", """ & strText & """, """ & strSearch & """) = " & intResult ' البحث من موقع مختلف intStart = 4 intResult = InStr(intStart, strText, strSearch) Debug.Print "الحالة 2: InStr(" & intStart & ", """ & strText & """, """ & strSearch & """) = " & intResult ' البحث عن حرف غير موجود strSearch = "z" intStart = 1 intResult = InStr(intStart, strText, strSearch) Debug.Print "الحالة 3: InStr(" & intStart & ", """ & strText & """, """ & strSearch & """) = " & intResult ' البحث في نص فارغ strText = "" strSearch = "a" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 4: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult ' البحث عن كلمة داخل جملة strText = "Access VBA" strSearch = "VBA" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 5: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult ' البحث المتكرر لنفس الكلمة strText = "abcabcabc" strSearch = "abc" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 6: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult ' البحث من منتصف السلسلة intResult = InStr(5, strText, strSearch) Debug.Print "الحالة 7: InStr(5, """ & strText & """, """ & strSearch & """) = " & intResult ' البحث مع اختلاف حالة الأحرف strText = "TestCase" strSearch = "case" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 8: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult & " (Compare = Binary افتراضي)" ' استخدام vbTextCompare لتجاهل حالة الأحرف intResult = InStr(1, strText, strSearch, vbTextCompare) Debug.Print "الحالة 9: InStr(1, """ & strText & """, """ & strSearch & """, vbTextCompare) = " & intResult Public Sub TestInStrFunction() Dim strText As String Dim strSearch As String Dim intStart As Integer Dim intResult As Integer Debug.Print String(70, "=") Debug.Print "اختبار دالة InStr" Debug.Print String(70, "=") ' الحالة 1: البحث عن حرف موجود من البداية strText = "Mohesam" strSearch = "a" intStart = 1 intResult = InStr(intStart, strText, strSearch) Debug.Print "الحالة 1: InStr(" & intStart & ", """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 2: البحث بعد الموضع الابتدائي intStart = 4 intResult = InStr(intStart, strText, strSearch) Debug.Print "الحالة 2: InStr(" & intStart & ", """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 3: البحث عن حرف غير موجود strSearch = "z" intStart = 1 intResult = InStr(intStart, strText, strSearch) Debug.Print "الحالة 3: InStr(" & intStart & ", """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 4: سلسلة فارغة strText = "" strSearch = "a" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 4: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 5: البحث عن كلمة كاملة strText = "Access VBA" strSearch = "VBA" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 5: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 6: البحث عن نفس الكلمة مكررة strText = "abcabcabc" strSearch = "abc" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 6: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 7: بدء البحث من منتصف النص intResult = InStr(5, strText, strSearch) Debug.Print "الحالة 7: InStr(5, """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 8: حساس لحالة الأحرف strText = "TestCase" strSearch = "case" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 8: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult & " (Compare = Binary افتراضي)" ' الحالة 9: تجاهل حالة الأحرف باستخدام vbTextCompare intResult = InStr(1, strText, strSearch, vbTextCompare) Debug.Print "الحالة 9: InStr(1, """ & strText & """, """ & strSearch & """, vbTextCompare) = " & intResult End Sub 2- ملخص سريع مباشر للحالات Public Sub TestInStrCases() Debug.Print "==================================================" Debug.Print "اختبار دالة InStr" Debug.Print "==================================================" Debug.Print "الحالة 1: InStr(1, ""Mohesam"", ""a"") = "; InStr(1, "Mohesam", "a") Debug.Print "الحالة 2: InStr(4, ""Mohesam"", ""a"") = "; InStr(4, "Mohesam", "a") Debug.Print "الحالة 3: InStr(1, ""Mohesam"", ""z"") = "; InStr(1, "Mohesam", "z") Debug.Print "الحالة 4: InStr(1, """", ""a"") = "; InStr(1, "", "a") Debug.Print "الحالة 5: InStr(1, ""Access VBA"", ""VBA"") = "; InStr(1, "Access VBA", "VBA") Debug.Print "الحالة 6: InStr(1, ""abcabcabc"", ""abc"") = "; InStr(1, "abcabcabc", "abc") Debug.Print "الحالة 7: InStr(5, ""abcabcabc"", ""abc"") = "; InStr(5, "abcabcabc", "abc") Debug.Print "الحالة 8: InStr(1, ""TestCase"", ""case"") = "; InStr(1, "TestCase", "case") Debug.Print "الحالة 9: InStr(1, ""TestCase"", ""case"", vbTextCompare) = "; InStr(1, "TestCase", "case", vbTextCompare) Debug.Print "==================================================" End Sub استخدام احترافي البحث عن رموز داخل نص دالة InStr يمكن توظيفها داخل دوال أكثر تقدما للبحث عن مجموعة من الرموز داخل نص معين Public Function GetSymbolsInText(ByVal strText As String, ByVal arrSymbols As Variant, ByRef arrFound() As String) As Boolean Dim varSymbol As Variant Dim colFound As Collection Set colFound = New Collection ' البحث عن كل رمز في النص For Each varSymbol In arrSymbols If InStr(strText, varSymbol) > 0 Then On Error Resume Next ' لتجنب تكرار العناصر في المجموعة colFound.Add varSymbol, CStr(varSymbol) On Error GoTo 0 End If Next ' تجهيز النتائج النهائية If colFound.Count > 0 Then ReDim arrFound(0 To colFound.Count - 1) Dim i As Long For i = 1 To colFound.Count arrFound(i - 1) = colFound(i) Next i GetSymbolsInText = True Else ReDim arrFound(-1 To -1) GetSymbolsInText = False End If End Function تجربة هذه الدالة Public Sub TestGetSymbolsInText() Dim arrSymbols As Variant Dim arrFound() As String Dim bolFound As Boolean Dim strTest As String arrSymbols = Array(",", ";", "|", "/", "\", "-", "_") strTest = "Mohesam-2025/Report_Aug" ' تنفيذ البحث bolFound = GetSymbolsInText(strTest, arrSymbols, arrFound) ' عرض النتائج If bolFound Then Debug.Print "تم العثور على الرموز التالية:" Dim i As Long For i = LBound(arrFound) To UBound(arrFound) Debug.Print arrFound(i) Next i Else Debug.Print "لا يوجد أي رمز" End If End Sub Sub TestTextCompareBehavior() Dim str1 As String Dim str2 As String str1 = "Access" str2 = "access" ' المقارنة الثنائية (تراعي حالة الأحرف) ' - لن تنجح Debug.Print "BinaryCompare: "; InStr(1, str1, str2, vbBinaryCompare) ' المقارنة النصية (تتجاهل حالة الأحرف) ' - ستنجح Debug.Print "TextCompare: "; InStr(1, str1, str2, vbTextCompare) End Sub الكود السابق يوضح الفرق بين نمطي المقارنة في دالة InStr vbBinaryCompare: يقارن مع مراعاة حالة الأحرف (case-sensitive) vbTextCompare: يقارن بدون مراعاة حالة الأحرف (case-insensitive) النتيجة 0 في المقارنة الثنائية تعني أن "access" لم يتم العثور عليها داخل "Access" بسبب اختلاف حالة الحروف أما في TextCompare فتم العثور على "access" في بداية "Access" لأن الحالة تم تجاهلها المعامل الرابع في InStr InStr(Start, String1, String2 , Compare) إذا لم يتم تحديد CompareMethod فإن Access يستخدم الإعداد الافتراضي (غالبا vbBinaryCompare) لذلك ينصح دائما بتحديد نوع المقارنة صراحة لتفادي النتائج غير المتوقعة خاصة عند تجاهل حالة الأحرف الخلاصــــــــــة InStr تعيد موضع أول ظهور لسلسلة داخل سلسلة أخرى (يبدأ من 1) تعيد 0 إذا لم يتم العثور على تطابق يمكن تخصيص نوع المقارنة باستخدام المعامل الرابع مفيدة لبناء دوال متقدمة لمعالجة النصوص والرموز لتجاهل حالة الأحرف استخدم vbTextCompare لا تعتمد على القيمة الافتراضية في Compare حددها دائما لتفادي النتائج غير المتوقعة هناك دالة مكملة لـ InStr تسمى InStrRev تقوم بالبحث من نهاية النص إلى بدايته قد تكون مفيدة جدا في بعض الحالات (مثل البحث عن آخر امتداد أو آخر فاصل) InStr(1, "file.name.txt", ".") ' 5 InStrRev("file.name.txt", ".") ' 10 بكده الشرح انتهى ولتحقيق اكبر قدر ممكن من الاستفادة وفيما يخص النقطة التالية: مفيدة لبناء دوال متقدمة لمعالجة النصوص والرموز دى فكرة كود داخل وحدة نمطية عامة فى الاعتماد على كل من InStr , InStrRev اتركها لكم للاستمتاع بها Option Compare Database Option Explicit Public Enum TextCase AsIs = 0 ' كما هو Lower = 1 ' أحرف صغيرة Upper = 2 ' أحرف كبيرة Proper = 3 ' أول حرف كبير End Enum ' تعريفات الأنواع Public Enum FilePartType FileNameWithExtension ' اسم الملف مع الامتداد FileNameOnly ' اسم الملف بدون الامتداد FileExtensionOnly ' الامتداد بدون النقطة FileExtensionWithDot ' الامتداد مع النقطة FullFolderPath ' المسار الكامل للمجلد ContainingFolderName ' اسم المجلد الحاوي فقط RootDrive ' الجذر (مثل C:\ أو اسم السيرفر) VersionOnly ' الإصدار فقط (مثل v1.2) DateOnly ' التاريخ فقط (مثل 2025-07-17) FullUNCPath ' المسار الكامل بصيغة UNC FileURL ' المسار بصيغة URL FileNameWithoutVersionOrDate ' اسم الملف بدون الإصدار أو التاريخ ServerAndShare ' السيرفر والمشاركة من مسار UNC End Enum ' كائنات على مستوى الوحدة لتحسين الأداء Private objFSO As Object Private objRegEx As Object ' الدالة الرئيسية لاستخراج أجزاء المسار Public Function ExtractFilePartPro( _ ByVal strPath As String, _ Optional ByVal enmPart As FilePartType = FileNameWithExtension, _ Optional ByVal enuTextCase As TextCase = AsIs, _ Optional ByRef strVersion As String = "", _ Optional ByRef strDate As String = "", _ Optional ByRef strError As String = "" _ ) As String Dim strResult As String Dim lngPos As Long Dim strFileName As String Dim strFolder As String Dim strExt As String Dim strParent As String Dim colMatches As Object Dim vMatch As Variant ' تهيئة رسالة الخطأ إلى فارغة strError = "" ' إنشاء الكائنات إذا لم تكن موجودة If objFSO Is Nothing Then Set objFSO = CreateObject("Scripting.FileSystemObject") If objRegEx Is Nothing Then Set objRegEx = CreateObject("VBScript.RegExp") With objRegEx .Global = True .IgnoreCase = True ' نمط محسن لدعم إصدارات مع أحرف وتواريخ بصيغ مختلفة .Pattern = "(v[\d\.]+[a-zA-Z-]*)|((?:19|20)\d{2}[-_/]?\d{2}[-_/]?\d{2}|\d{8})" End With End If On Error GoTo ErrHandler ' تنظيف المسار strPath = Trim(strPath) ' التحقق من المسار الفارغ If strPath = "" Then strError = "المسار فارغ" ExtractFilePartPro = "" Exit Function End If ' استخراج اسم الملف If objFSO.FileExists(strPath) Or InStrRev(strPath, "\") > 0 Then strFileName = Mid(strPath, InStrRev(strPath, "\") + 1) Else strFileName = strPath End If ' استخراج المسار الكامل للمجلد strFolder = Left(strPath, Len(strPath) - Len(strFileName)) ' استخراج الامتداد (يدعم الامتدادات المركبة مثل .tar.gz) If InStr(strFileName, ".") > 0 Then lngPos = InStrRev(strFileName, ".") strExt = Mid(strFileName, lngPos) If LCase(strExt) = ".gz" And InStrRev(strFileName, ".tar.gz") > 0 Then strExt = ".tar.gz" End If Else strExt = "" End If ' استخراج اسم المجلد الحاوي If Right(strFolder, 1) = "\" Then strFolder = Left(strFolder, Len(strFolder) - 1) If InStrRev(strFolder, "\") > 0 Then strParent = Mid(strFolder, InStrRev(strFolder, "\") + 1) Else strParent = "" End If ' استخراج الإصدار والتاريخ باستخدام RegExp If objRegEx.Test(strFileName) Then Set colMatches = objRegEx.Execute(strFileName) For Each vMatch In colMatches If Left(LCase(vMatch), 1) = "v" Then strVersion = vMatch Else strDate = vMatch End If Next End If ' اختيار الجزء المطلوب Select Case enmPart Case FileNameWithExtension strResult = strFileName Case FileNameOnly If strExt <> "" Then strResult = Left(strFileName, Len(strFileName) - Len(strExt)) Else strResult = strFileName End If Case FileExtensionOnly If strExt <> "" Then strResult = Mid(strExt, 2) Case FileExtensionWithDot strResult = strExt Case FullFolderPath strResult = strFolder Case ContainingFolderName strResult = strParent Case RootDrive If Left(strPath, 2) = "\\" Then strResult = Split(strPath, "\")(2) ' اسم السيرفر فقط Else strResult = Left(strPath, 3) End If Case VersionOnly strResult = strVersion Case DateOnly strResult = strDate Case FullUNCPath strResult = strPath Case FileURL If Left(strPath, 2) = "\\" Then strResult = "file://" & Replace(strPath, "\", "/") Else strResult = "file:///" & Replace(strPath, "\", "/") End If Case FileNameWithoutVersionOrDate strResult = objRegEx.Replace(strFileName, "") Case ServerAndShare If Left(strPath, 2) = "\\" Then Dim arrParts As Variant arrParts = Split(strPath, "\") If UBound(arrParts) >= 3 Then strResult = "\\" & arrParts(2) & "\" & arrParts(3) Else strResult = "" End If Else strResult = "" End If End Select ' تنسيق النص حسب الخيار المحدد Select Case enuTextCase Case Lower strResult = LCase(strResult) Case Upper strResult = UCase(strResult) Case Proper strResult = StrConv(strResult, vbProperCase) Case Else ' AsIs, لا تغيير End Select ExtractFilePartPro = strResult ExitHere: Set colMatches = Nothing Exit Function ErrHandler: strError = "خطأ: " & Err.Description ExtractFilePartPro = "" Resume ExitHere End Function ' روتين اختبار موسع Public Sub TestEnhanced() Dim strPath As String Dim strUNCPath As String Dim strResPath As String Dim strRes As String Dim strVer As String Dim strDat As String Dim strError As String ' تعيين مسارات الاختبار strPath = "C:\Test\MyDataBase\Officena.Accdb" strUNCPath = "\\Server\Myhiba\Officena.Accdb" strResPath = "C:\Test\MyFile_v3.4_2025-07-17.tar.gz" Debug.Print String(70, "=") Debug.Print "اختبارات استخراج أجزاء المسار" Debug.Print String(70, "=") ' اختبار الأجزاء الأساسية Debug.Print "اختبار الأجزاء الأساسية" Debug.Print String(70, "-") Debug.Print " الاسم مع الامتداد : " & ExtractFilePartPro(strPath, FileNameWithExtension) Debug.Print " الاسم فقط : " & ExtractFilePartPro(strPath, FileNameOnly) Debug.Print " الامتداد فقط : " & ExtractFilePartPro(strPath, FileExtensionOnly) Debug.Print " الامتداد مع النقطة : " & ExtractFilePartPro(strPath, FileExtensionWithDot) Debug.Print " اسم المجلد الحاوي : " & ExtractFilePartPro(strPath, ContainingFolderName) Debug.Print " المسار بدون اسم الملف : " & ExtractFilePartPro(strPath, FullFolderPath) Debug.Print " الجذر : " & ExtractFilePartPro(strPath, RootDrive) Debug.Print " المسار بصيغة UNC : " & ExtractFilePartPro(strUNCPath, FullUNCPath) Debug.Print " المسار بصيغة URL : " & ExtractFilePartPro(strUNCPath, FileURL) Debug.Print String(70, "-") ' اختبار استخراج الإصدار والتاريخ strRes = ExtractFilePartPro(strResPath, FileNameOnly, AsIs, strVer, strDat) Debug.Print "اختبار استخراج الإصدار والتاريخ" Debug.Print " الاسم : " & strRes Debug.Print " الإصدار : " & strVer Debug.Print " التاريخ : " & strDat ' اختبار الخيارات الجديدة Debug.Print " FileNameWithoutVersionOrDate: " & ExtractFilePartPro(strResPath, FileNameWithoutVersionOrDate) Debug.Print " ServerAndShare : " & ExtractFilePartPro(strUNCPath, ServerAndShare) ' اختبار معالجة الأخطاء strRes = ExtractFilePartPro("", FileNameWithExtension, AsIs, , , strError) Debug.Print " Empty path result : " & strRes & ", Error: " & strError strRes = ExtractFilePartPro("C:\Invalid\Path", FileNameWithExtension, AsIs, , , strError) Debug.Print " Invalid path result : " & strRes & ", Error: " & strError ' اختبار تنسيق الحروف Debug.Print " Upper case : " & ExtractFilePartPro(strPath, FileNameWithExtension, Upper) Debug.Print "======================================================" End Sub

وعليكم السلام ورحمة الله وبركاته .. تستطيع ذلك من خلال ملفك المرفق كالآتي :- في الخلية B5 ( لحساب الأيام ) :- =MOD(B3+B4,30) في الخلية C5 ( لحساب الأشهر ) :- =MOD(C3+C4+QUOTIENT(B3+B4,30),12) في الخلية D5 ( لحساب السنوات ) :- =D3+D4+QUOTIENT(C3+C4+QUOTIENT(B3+B4,30),12) وتستطيع أيضاً عرض التفصيل كاملاً في خلية واحدة . على سبيل المثال . قمت بدمج الخلايا B+C+D = 6 في خلية واحدة ، وأدرجت فيها المعادلة التالية :- =D3+D4+QUOTIENT(C3+C4+QUOTIENT(B3+B4,30),12) & " سنوات, " & MOD(C3+C4+QUOTIENT(B3+B4,30),12) & " أشهر, " & MOD(B3+B4,30) & " أيام" وهذه صورة من النتيجة النهائية :- Number of Serveces.zip

وعليكم السلام , هناك اسباب عديدة لثقل ملف الاكسل منها : كثرة المعادلات , كثرة الرسومات , كثرة التنسقات العادية والشرطية لو أنك ترسل ورقة واحدة من هذا الملف الثقيل لديك فيمكننا أن نكتشف بعض الحلول . تقبل تحياتي

اهاااا ، وهو بالفعل ما قمت به ولكن بطريقة أخرى

اعتقد أني عرفت المشكلة جرب المثال الان وأخبرنا إذا ظهرت الرسالة أم لا مع تحياتي baseM11.rar

مرفق لك مثالك بعد التعديل قمت بإضافة جدول tblDates والإستعلام qryDates النتيجة النهائية ستجدها في الاستعلام Query1 أرجو أن يكون هو ماتبحث عنه مع تحياتي Database1.rar

تجربة تم حذف المسافات والبحث بدالة VLOOKUP تجربة للرفع (2).xlsx

تفضل برنامج تصميم سريع لعله يفي بالغرض أجازات 2.xlsm

حل رائع للاستاذ/ محمد إليك حل آخر بالأكواد مع اظهار الكلمات المكررة وعددها الاقتباس 2.xlsm

يمكنك تجربة هذه المعادلة =SUMPRODUCT(--ISNUMBER(SEARCH(" " & TRIM(MID(SUBSTITUTE(A2," ",REPT(" ",100)), (ROW(INDIRECT("1:" & LEN(A2)-LEN(SUBSTITUTE(A2," ",""))+1))-1)*100+1, 100)) & " ", " " & $D$2 & " "))) بالتوفيق

في المرفق :- وحتى لو كانت رقمية ، جربت النتيجة وبدون أخطاء او خلل فيها