ابو جودي

الكود الأول أفضل لأنه: يضمن كتابة قيمة منسقة بشكل صحيح لنوع Date/Time باستخدام Format(datResult, "hh:nn") ورمزي # يحدد السجلات بدقة (id=2 وid=3) وبذلك يتجنب أي سجلات غير مرغوبة أكثر وضوحا للوضع الحالي حيث الهدف هو جمع ساعتين محددتين فقط الكود الثاني أقل ملاءمة لأنه: يكتب قيمة رقمية (Double) مباشرة مما قد يؤدي إلى تخزين غير صحيح (مثل أيام بدلا من ساعات) في حقل Date/Time شرط ftraName IN ('1','2') AND ID > 1 قد يشمل سجلات غير مرغوبة إذا كانت هناك سجلات إضافية بـ ftraName='1' أو '2' وID > 3

لا تكتفى بما لديك كلف نفسك عناء محاولة ايجاد و معرفة الفرق بين 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

ماشى ممكن كده سطر واحد استعلام تحديث لتحقيق المطلوب وكمان الاعتماد الى المعرف 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 وبالمرة ده تعديل بسيط للدالة داخل الوحدة النمطية '' ========================================================== '' الدالة: 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

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

هل يفى ذلك بالغرض و يحقق المطلوب ؟ Private Sub cmdSave_Click() On Error GoTo ErrorHandler Dim rst As DAO.Recordset Dim datInterval As Date Dim dblTotalMinutes As Double Dim strFtraName As String Set rst = CurrentDb.OpenRecordset("tbl_Ftrat", dbOpenDynaset) dblTotalMinutes = 0 Do While Not rst.EOF strFtraName = Trim(Nz(rst!ftraName, "")) If strFtraName = "فترة صباحية" Or strFtraName = "فترة مسائية" Then If Not IsNull(rst!countWorkHours) Then ' تحويل الوقت إلى دقائق: القيمة * 24 * 60 dblTotalMinutes = dblTotalMinutes + (rst!countWorkHours * 24 * 60) If DebugMode Then Debug.Print "تمت إضافة عدد الدقائق: "; rst!countWorkHours End If End If rst.MoveNext Loop ' تحويل عدد الدقائق الإجمالية إلى قيمة Time لتخزينها في الحقل Date/Time datInterval = dblTotalMinutes / (24 * 60) rst.MoveFirst Do While Not rst.EOF strFtraName = Trim(Nz(rst!ftraName, "")) If strFtraName Like "*فترتين*" Then rst.Edit rst!countWorkHours = datInterval rst.Update Exit Do End If rst.MoveNext Loop countWorkHours.Requery Me.Repaint rst.Close Set rst = Nothing MsgBox " تم تحديث عدد ساعات الفترة المجمعة بنجاح.", vbInformation Exit Sub ErrorHandler: MsgBox " خطأ: " & Err.Description, vbCritical If Not rst Is Nothing Then rst.Close Set rst = Nothing End Sub

تمام حضرتك عاوز مجموع ساعات العمل للفترين الصباحية والمسائية فقط انا كده فهمت صح ولو انا فهمت صح فى خطأ فى حساب الفترة المسائية هى الان : 5:40 والمفروض الصح تكون : 6:10

يعنى المفروض يكون الفترين موجودين حضور وانصراف وعند الضغط على زر الحفظ يتم جمع ساعات العمل ؟

انا مش فاهم معلش محتاج لتوضيح

ايه الحلاوة دى الله عليك بجد فعلا الفكرة ولا اروع وعلشان عجبتنى الفكرة كتبت لها هذا الكود الذى يقوم بانشاء الجدول وملئ البيانات وانشاء الاستعلام بشكل آلى وديناميكى بدون ادنى جهد وطبعا لم انسى الاخذ فى الحسبان اضفاء المرونة التامة بالتحكم فى كل كبيرة صغيرة الكود 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

وبسبب هذه الجملة اعيد صياغة الكود فى الوحدة النمطية العامة ليكون بهذا الشكل لاضافة قاموس لدعم اللغات المتعددة واضافة الاختصارات او الخطاء الشائعة او الممكنة فى المستقبل 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

بالنسبة للدالة Hour بهذا الشكل IIf(Hour([chekin]) < 12, "الصباح", "المساء") هذا السطر لا يتأثر بالتنسيق الإقليمي للنظام طالما أن الحقل [chekin] يحتوي فعليا على قيمة من النوع Date/Time لماذا لا يتأثر؟ الدالة Hour(...) تعتمد على القيمة الداخلية للوقت المخزن في Access وليس على الشكل المعروض Access يخزن التاريخ/الوقت كقيمة رقمية مزدوجة (Double) الجزء الصحيح للتاريخ والجزء الكسري للوقت نظام العرض (12/24 ساعة – AM/PM) يخص شكل العرض فقط بينما الدالة Hour() دائما ترجع رقم بين 0 و23 بغض النظر عن التنسيق ولكن ماذا لو كان نوع البيانات للحقل نص وليس تاريخ لابد من الاستخدام بالشكل التالى IIf(IsDate([chekin]) And Hour(CDate([chekin])) < 12, "الصباح", "المساء")

طيب ايه الفرق بين Public Function GetTimePeriod(ByVal varDateTime As Variant) As String Public Function GetPeriod(dt As Date) As String GetTimePeriod أكثر أمانا ومرونة لان الوسيط Variant بعكس الوسيط Date صارم التحقق من Null أو "" التحويل إلى تاريخ باستخدام CDate يدعم Null / نصوص صالحة للتحويل مناسب للاستخدام من النماذج / الحقول مباشرة

كلام حضرتك صح جدا جدا انا فقط افضل الكود فى وحدة نمطية لاستخدامه فى اى مكان وتوفيرا للعناء

لا نحن فى المساء والكود يعمل عندى بنجاح الدالة التي تعتمد على Hour() ترجع عددا صحيحا من 0 إلى 23 لذلك Hour(11:59) = 11 >>--> الصباح و Hour(12:00) = 12 >>--> المساء وللتجربة Public Sub Test_GetTimePeriod() Dim arrTimes As Variant Dim i As Long Dim dtmSample As Date Dim strResult As String arrTimes = Array( _ "00:00", _ "05:30", _ "11:59", _ "12:00", _ "12:05 AM", _ "12:05 PM", _ "12:01", _ "13:45", _ "17:00", _ "23:59" _ ) Debug.Print "-----------------------------" Debug.Print "الوقت" & vbTab & ">>->" & vbTab & "الفترة" Debug.Print "-----------------------------" For i = LBound(arrTimes) To UBound(arrTimes) dtmSample = TimeValue(arrTimes(i)) strResult = GetTimePeriod(dtmSample) Debug.Print Format(dtmSample, "hh:nn AM/PM") & vbTab & " >>-> " & vbTab & strResult Next i End Sub

وعليكم السلام طبعا ممكن من خلال الكود التالى Public Function GetTimePeriod(ByVal varDateTime As Variant) As String On Error GoTo ErrHandler If IsNull(varDateTime) Or varDateTime = "" Then GetTimePeriod = "" Exit Function End If Dim dtmTime As Date dtmTime = CDate(varDateTime) Dim lngHour As Long lngHour = Hour(dtmTime) If lngHour < 12 Then GetTimePeriod = "الصباح" Else GetTimePeriod = "المساء" End If Exit Function ErrHandler: GetTimePeriod = "" End Function وللاستدعاء GetTimePeriod([CheckIn])

دالة 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

انت مش قلت ما ينفعش يا عم انت يلا ارفع واشوت دى امثله للتوضيح 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: استخدام المعامل الرابع للمقارنة الثنائية أو النصية intResult = InStr(1, strText, strSearch, vbTextCompare) Debug.Print "الحالة 9: InStr(1, """ & strText & """, """ & strSearch & """, vbTextCompare) = " & intResult Debug.Print String(70, "=") End Sub 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 نعم لسنا بحاجة لمعرفة المكان ولكن الدالة ترجع 0 فى حالة عدم وجود موقع للعلامة يعنى الدالة بس من خلالها بنبنى شرط لو فى موقع للعلامة او لا يوجد موقع

شرح دالة InStr شكل وطريقة استخدام الدالة InStr(string1, string2) تستخدم InStr للبحث عن موضع أول ظهور لسلسلة (string2) داخل سلسلة أخرى (string1) ترجع موقع أول تطابق (كمؤشر حرفي يبدأ من 1) أو ترجع 0 إذا لم يتم العثور على أي تطابق string1: السلسلة النصية الأساسية التي يتم البحث بداخلها string2: السلسلة النصية المطلوب العثور عليها الناتج: رقم موضع أول تطابق أو 0 إذا لم توجد InStr("123-456", "-") ' النتيجة: 4 (لأن "-" في الموضع الرابع) InStr("abc", "z") ' النتيجة: 0 (لأن "z" غير موجودة) InStr("ابو خليل:الاستاذ",":") ' النتيجة: 9 InStr("Mohamed", "h") ' النتيجة: 3 (لأن الحرف "h" أول ظهور له في الموضع الثالث) InStr(5, "Banana", "a") ' النتيجة: 5 (يبدأ من الموضع الخامس ويجد "a" في الموضع 5)

ايون ينفع نعم <> False يعمل لكنه أقل وضوح من <> 0 أو > 0 تذكر أن InStr ترجع رقم موضع وليس قيمة منطقية لذلك من الطبيعي تقارنها بأرقام مش بقيم منطقية

الدالة InStr تبحث عن وجود سلسلة نصية داخل سلسلة أخرى ترجع الموضع الرقمي لأول ظهور للجزء المطلوب (أي رقم أكبر من صفر) إذا تم العثور عليه وترجع الرقم 0 إذا لم يتم العثور على الجزء المطلوب تركيب الدالة هو: InStr([النص الأصلي], [النص الذى نريد البحث عنه]) اذا InStr([Modah];"-")<>0 [Modah] هو الحقل الذي يحتوي على البيانات النصية اى هو النص الأصلى "-" هو النص الذى نريد البحث عنه >-->> علامة السالب <>0 تعني طالما أن علامة السالب موجودة في أي موضع داخل النص فيعتبر الشرط صحيح طيب بالنسبة لسؤال حضرتك الفاصلة في الحقل ":" لكن الفاصلة في الدالة "-" نركز فقط على ظهور علامة السالب (-) داخل القيمة الكاملة للحقل وليس على علاقة للفاصل ":" هنا لأننا لا نقوم بتقسيم القيمة بل فقط نبحث عن وجود علامة السالب (-) لماذا لم تلون القيم التي تحتوي على صفر؟ لأن الشرط يبحث فقط عن وجود السالب علامة السالب (-) "0:0" لا تحتوي على علامة السالب (-) الشرط يعطي False فلا يتم تلوينه "-0:1" تحتوي على علامة السالب (-) الشرط يعطي True فلذلك يتم تلوينه

فقط استخدم فى خاصية التسيق الشرطى لعنصر هذا الحقل InStr([FieldName],"-")<>0 طبعا مع تغيير : FieldName بما يتناسب معك واختر اللون هذا اقصر طريق داخل التقرير ولو تريد التصفية فقط فى الاستعلام للقيم الموجبة استخدم فى معيار الحقل: FieldName >InStr([FieldName],"-")<>0 اما لو تريد القيم السالبة فقط فى معيار الحقل : FieldName InStr([FieldName],"-")<>0

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

انت تقصد لاقيت نفسك فاضى قلت فى عقل بالك تعمل ايه تعمل ايه يا واد فؤش اه الواد او جودى هنا وعمال يخبط دماغه فى الحيط .. اسيبــه ؟! .... لا ... اروح اعمل له Error فى دماغه بزياده قبل ما يروح على شغله وبعدين ادخل انام عاش عليك يا فؤش خلاااااااااااااااااااص مباقاش فاضل تكـــــــــه بح خلاص على ايدك يا فؤش أفندى خلصت التكـه

يا فؤش افندى لا يعيب الكود كثرة الاسطر أو طوله انت استخدمت : سلسلة مباشرة انا استخدمت : مصفوفة ثم Join واستخدمت شرط للتحقق من البداية والنهاية واعتقد ان (مصفوفة ثم Join) : أسرع وأكثر كفاءة عند كثرة التواريخ (المصفوفة أفضل من تجميع نصي مباشر) غير كده مفيش أى فروقات تانى عير الفاصلة فــ إيه بئه أنا مش فاهم

من أجل ذلك كتبت الكود بالشكل ده يا استاذ فؤش Public Function GetDatesBetween(ByVal dtmStartDate As Date, ByVal dtmEndDate As Date) As String If dtmStartDate > dtmEndDate Then GetDatesBetween = "" Exit Function End If Dim dtmCurrentDate As Date Dim arrDates() As String ReDim arrDates(0 To DateDiff("d", dtmStartDate, dtmEndDate)) Dim lngIndex As Long For dtmCurrentDate = dtmStartDate To dtmEndDate arrDates(lngIndex) = Format(dtmCurrentDate, "yyyy-mm-dd") lngIndex = lngIndex + 1 Next dtmCurrentDate GetDatesBetween = Join(arrDates, " | ") End Function