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

السلام عليكم سوف نشرح في هذا الموضوع طريقة سهلة جدا لإضافة QR CODE للتقرير داخل مربع نص و يدعم اللغة العربية كذلك أولا: هناك ملف تنفيذي يقوم بتسجيل الأدوات و نوع الخط نقوم بتثبيته داخل الكمبيوتر ثانيا: لإضافة QR CODE نقوم باستدعاء الوحدة النمطية الموجودة في المرفق في مصدر عنصر التحكم لمربع النص و نغير نوع الخط إلى BCW_2D =QrCode([T];1;1;صواب;4;1) [T]: هو مربع نص نأخذ منه البيانات و هذا رابط المصدر : https://barcodewiz.com/user-manual/qr-code-fonts/create_qr_code_barcodes_in_ms_access.aspx و أخيرا تمتع بـQR CODE رائع أرجوا من الإخوة تجربته و موافاتنا بالنتائج. توليد QR CODE.rar

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

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

ممكن نجربة هذا الكود اذا لم يكن هناك صفحة بأي اسم يقوم الماكرو باضافة صفحة جديدة بهذا الاسم و ينقل البيانات اليها Option Explicit Sub Add_sheet() Dim myname As Worksheet Dim P As Worksheet Dim sh_n%, k%, i% Set P = Sheets("اليوميه") sh_n = Application.CountA(P.Range("B:B")) - 1 Dim x%, t%: t = 2 Dim mn$ Application.ScreenUpdating = False ''''''''''''''''''''''''''''''''''''''''' For i = 2 To sh_n On Error Resume Next mn = Sheets(P.Range("b" & i) & "").Name x = Len(mn) If x = 0 Then P.Copy after:=Sheets(Sheets.Count) With ActiveSheet .Name = P.Range("b" & i) .Range("G14") = P.Range("F" & i) .Range("a1").CurrentRegion.Offset(1).ClearContents .Range("A:A").NumberFormat = ("dd- mm-yyy") For k = 2 To sh_n + 1 If P.Range("b" & k) = ActiveSheet.Name Then ActiveSheet.Cells(t, 1).Resize(, 4).Value = _ P.Range("A" & k).Resize(, 4).Value t = t + 1 End If Next End With '========================================= Else Set myname = Sheets(P.Range("b" & i) & "") myname.Range("a1").CurrentRegion.Offset(1).ClearContents For k = 2 To sh_n + 1 If P.Range("b" & k) = myname.Name Then myname.Cells(t, 1).Resize(, 4).Value = _ P.Range("A" & k).Resize(, 4).Value t = t + 1 End If Next '''''''''''''''''''''''''''''''''''' End If mn = "" Err.Number = 0 t = 2 Next i P.Select Application.ScreenUpdating = True End Sub الملف مرفق tarhil_by_names.xlsm

العفو أخي

ممكن تبدليه بهذا الكود Private Sub Worksheet_Selectionchange(ByVal Target As Range) If Target.HasFormula = True Then ActiveCell.Offset(0, 1).Select ElseIf Target.MergeCells = True And Target.HasFormula = True Then Target.Offset(0, 1).Select ElseIf ActiveCell.HasFormula = True And ActiveCell.MergeCells = True Then ActiveCell.Offset(0, 1).Select End If End Sub و بعذ إذن أستاذنا الفاضل سليم أرى أن يكون التعديل هكذا اكتب في السطر الذي قبل كلمة Dim في الماكرو ActiveSheet.Unprotect "123" واكتب في السطر الذي قبل كلمة End sub ActiveSheet.Protect "123" Option Explicit Sub get_my_studiants() Application.ScreenUpdating = False ActiveSheet.Unprotect "123" Dim A As Worksheet Dim B As Worksheet Set A = Sheets("ALL_STD") Set B = Sheets("B") Dim col%, r, x, LB LB = B.Cells(Rows.Count, "B").End(3).Row If LB < 5 Then LB = 5 B.Range("a5").Resize(LB - 4, 6).Clear Dim my_clas$: my_clas = B.Range("e2") Dim my_mad$: my_mad = B.Range("K2").Value If my_clas = "" Or my_mad = "" Then GoTo Exit_Sub col = A.Rows(1).Find(my_clas, lookat:=1).Column r = A.Columns(1).Find(my_mad, lookat:=1).Row x = Application.CountIf(A.Columns(1), my_mad) B.Range("b5").Resize(x).Value = _ A.Cells(r, 2).Resize(x).Value B.Range("c5").Resize(x, 3).Value = _ A.Cells(r, col).Resize(x, 3).Value With B.Range("A5").Resize(LB - 4, 6) .Columns(1).Formula = "=if(B5="""","""",max($A$4:a4)+1)" .Columns(1).Interior.ColorIndex = 6 .Borders.LineStyle = 1 .Columns(6).Formula = "=RANK(E5,$E$5:$E$29,0)+COUNTIF($E5:E$5,E5)" .Value = .Value .Font.Size = 26 .Font.Bold = True .InsertIndent 1 End With Exit_Sub: Application.ScreenUpdating = True ActiveSheet.Protect "123" End Sub My_students (1).xlsm

جزاكم الله كل خير

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

وعليكم السلام-تفضل لا يمكن الا بهذه الطريقة لا تترك رقم الوحدة فى اى صف فارغ تحصيل2.xlsm

وعليكم السلام ورحمة الله وبركاته ارفق مثال اخي الكريم لفهم المطلوب ولك الشكر تحياتي

تفضل اخي الكريم لاحظ مصدر combobox في النموذج والمعيار الموجود في الاستعلام Query1 w.rar تحياتي

تفضل أخي error.rar

انظر المرفق ..... لسرعة الاجابة حاولت تعديل حقول الجدول لديك .... Database1.mdb

بالتوفيق ....

جرب الكتابة داخل المربع الأول وانظر النتيجة .... ايقاف علامة جدولة.accdb

تفضل ....... Data.rar

اسف جدا كثرة الملفات علي .... انظر المرفق الجديد ..... تم تعديل المرفق .....اسف مرة أخرى QR_code_-name.mdb

نعم ممكن ولكن في حالة كثرة السجلات مثل مثالك يحتاج وقت وايضا كفاءة جهاز الكمبيوتر ..... انظر المرفق هذا ما تريد تم تعديل المرفق .... Desktop1.rar

بعض أسئلة الاستبيانات تكون ايجابية و الاخرى سلبية ، و فى حال رغبت فى اخذ متوسطات لاجابات محور معين يضم اسئلة سلبية و ايجابية ، يجب عكس النتائج الرقمية المناظرة لقيمة الرد، فمثلا الاصل فى حالة مقياس ليكارد الخماس أن تكون اجابة اتفق جدا = 5 و اتفق = 4 ، .... و هكذا ، فاذا كانت الاسئلة كلها ايجابية و هناك سؤال سلبي فهنا يجب تعديل القيم لاجابات هذا السؤال لتكون اتفق جدا = 1 ، اتفق = 2 ، ... قبل اجراء اية عمليات حسابية على المحور مثل حساب المتوسط مثلا. و اذا كان التفريغ يدويا فيمكن مراعاة ذلك ، اما فى حالة استخدام ادوات الكترونية لجمع الاستبيان فان الارقام تكون مسجلة بالفعل و يجب تعديلها ، و قد تكون العملية مرهقة فى حالة تعدد المتغيرات او كبر حجم العينة. و بالطبع يمكن تعديل الاسئلة لتكون فى نفس المحور ايجابية او سلبية ، و لكن فى بعض الاحيان يكون من الاسهل على مجيب الاستبيان الاجابة عن الصيغة الايجابية او السلبية بحسب المتعارف عليه في بعض مجالات التخصص ، فبصرف النظر عن صحة وجود اسئلة سلبية و ايجابية فى نفس المحور ، للقيام بعملية تعديل (عكس) نتائج عدد من الاجابات لتحويلها من ايجابية الي سلبية بصورة الية ، قمت باعداد دالة فى الاكسيل لتقوم بهذا الغرض (مرفق المثال). لنفرض ان الاجابات الاصلية كانت عن درجة الاتفاق مع كون وقت المشروع مناسب ، و اردتا تغيير الاجابات لتعبر عن كون زمن المشروع غير مناسب كما هو مبين: و ذلك عن طريق استخدام الدالة التالية: Function Reverse_Ordinal2(original_Ordinal As Byte) Dim newVal As Byte Select Case original_Ordinal Case Is = 1 newVal = 5 Case Is = 2 newVal = 4 Case Is = 3 newVal = 3 Case Is = 4 newVal = 2 Case Is = 5 newVal = 1 Case Else newVal = 0 End Select Reverse_Ordinal2 = newVal End Function مرفق المثال و لتشغيله يجب تفعيل الماكرو فى ملف الاكسيل و يتم ادراج الكود فى ملف اخر عن طريق فتح شاشة محرر البيزيك ALT+F11 ثم : السحب للملف الحديد او اختيار ادراج موديول جديد و نسخ الكود او استخدام الدالة و الملف المرفق مفتوح و اذا لم يكن لك خبرة بالتعامل مع الكود ، و لا ترغب فى ذلك ، يمكنك استخدام الملف المرفق مباشرة للتحويل و سحب أو نسخ الدالة للاسفل لتمتد لعدد الاسطر المطلوب ، مع مراعاة تفعيل الماكرو عند فتح الملف لتعمل الدالة ReverseOrdinalLekerd.xlsm

السلام عليكم ورحمة الله وبركاته 🙂 عندما يكون برنامج الاكسس يعمل ، وفجأة بدأ بإعطاء رسائل خطأ وبدون اي تعديل في البرنامج ، او عند عمل تعديل على البرنامج يُغلق الاكسس: . طريقة العمل: سيفتح البرنامج ، ويجب عليك غلقه ، الى ان لا يفتح تلقائيا مرة اخرى. ولكن ، يجب دائما اخذ الاحتياط وعمل نسخة من البرنامج قبل عمل هذه الخطوات. اقدم لكم شرح بسيط عن الموضوع: في الكثير من الاوقات ، لما نعمل الكود ، نقوم بتعديل وتغيير وتضبيط الكود عدة مرات ، ولكن الاكسس في بعض الاحيان يبقى محتفظ بالكود القديم في ذاكرته !! لذلك : 1. اثناء البرمجة ، وبشكل يومي اقوم بتشغيل هذا الملف المرفق ، 2. وقبل تسليم البرنامج الى الزبون ، اقوم بتشغيل الملف للمرة الاخيرة ، واجهز البرنامج لتسليمه الى الزبون وهذا هو الكود المعدل عن النسخة السابقة: Private Sub cmd_Decompile_Click() Dim MSAccPath As String Dim RegKey As String Dim WSHShell 'As Object Dim waitOnReturn As Boolean: waitOnReturn = True ' Get MSACCESS.exe directory from the Registry RegKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\" & _ "CurrentVersion\App Paths\MSACCESS.EXE\Path" Set WSHShell = CreateObject("WScript.Shell") ' Get parent directory MSAccPath = WSHShell.RegRead(RegKey) ' Decompile WSHShell.Run Chr(34) & MSAccPath & "MSACCESS.EXE" & Chr(34) & " " & Chr(34) & Me.str_File_Single & Chr(34) & " /decompile", , waitOnReturn ' compact WSHShell.Run Chr(34) & MSAccPath & "MSACCESS.EXE" & Chr(34) & " " & Chr(34) & Me.str_File_Single & Chr(34) & " /compact", , waitOnReturn ' cmd compile WSHShell.Run Chr(34) & MSAccPath & "MSACCESS.EXE" & Chr(34) & " " & Chr(34) & Me.str_File_Single & Chr(34) & " /cmd compile", , waitOnReturn ' compact WSHShell.Run Chr(34) & MSAccPath & "MSACCESS.EXE" & Chr(34) & " " & Chr(34) & Me.str_File_Single & Chr(34) & " /compact", , waitOnReturn ' Clear shell var Set WSHShell = Nothing End Sub جعفر Decompile_2.zip

الشكر لله ثم لاخواننا واساتذتنا الذين تعلمنا ونتعلم منهم جزاهم الله خيرا وفيك بارك الله اخى تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق

شكراً لكم هو المطلوب بارك الله بجهودكم وزادكم من علمه

وعليكم السلام اخى خلف انظر التعديل ده هل هو ما تريد اذا كان هو فجزاه الله خيرا اخى @Ali Sadiq فقد استفدت منه هذا الكود الجميل تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق تصفية_نموذج_مسافة.rar

السلام عليكم ورحمة الله اخي الكريم أحمد الفلاحجى هههههههه لاشي بارك الله فيك اخي الكريم

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

تفضل أخي اليك التطبيق المثال تجربة قبول التكرار مع رسالة تحدير.rar

الاخ emam1424 شاهد المرفقات Test_1.rar

بل أرجو أن تفتح مشاركة جديدة تبحث فيها الأفكار المحاسبية وتطبيقاتها على قواعد بيانات أكسس 🤔

أ / مصطفى كمال متولى لا شكر على واجب المهم أنه تم تنفيذ المطلوب بنجاح

المشكلة لديك انت كما توقعت فيجب عليك تفعيل والتعليم على هذا الخيار ايضا وهو Trust Access

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

نعم أخي صدقت وصدق أستاذنا ومعلمنا أبوخليل قمت بالتعديل علي مرفق الأخ السائل وفقا لمراده رغم تحفظي علي طريقة العمل لعل لديه وجهة نظر لا نعلمها أما عن المرتجعات فبلغة المحاسبين هي قيد عكسي لعملية البيع أو الشراء بمعني: حساب المبيعات دائن بطبيعته (دائما يكون في الجانب الدائن) - فإن المرتجع المتعلق بالمبيعات لا بد أن يكون مدين وكذلك حساب المشتريات مدين بطبيعته (دائما يكون في الجانب المدين) - لذا لا بد أن تكون مرتجع المشتريات دائن وبلغة الأرقام فإن المعادلة لصافي المبيعات وصافي المشتريات تكون كالتالي: صافي المبيعات = اجمالي المبيعات - مرتجع المبيعات صافي المشتريات = اجمالي المشتريات - مرتجع المشتريات وهنا صورة لنموذج حـ/ المتاجرة الذي يوضح الفكرة بالأعلي

حياك الله أخي @haniameen وبالتوفيق ...

جرب هذا الماكرو Option Explicit Sub ABSCENT() Application.Calculation = xlCalculationManual Dim K As Worksheet, A As Worksheet Dim Ro_K%, col%, Ro_A%, i%, m%, t%: t = 1 Dim ALL$, ALPHA$, Str$: Str = "غ" ALL$ = " ": ALPHA = " " Set K = Sheets("keab"): Set A = Sheets("arhkeab") Ro_K = K.Cells(Rows.Count, 2).End(3).Row If Ro_K < 5 Then Exit Sub Ro_A = A.Cells(Rows.Count, 2).End(3).Row m = IIf(Ro_A < 5, 5, Ro_A + 2) For i = 5 To Ro_K If Application.CountIf(K.Cells(i, 6).Resize(1, 31), Str) = 0 Then _ GoTo My_next A.Cells(m, 2).Resize(, 2).Value = _ K.Cells(i, 2).Resize(, 2).Value For col = 6 To 36 If K.Cells(i, col) = Str Then ALL = ALL & Day(K.Cells(4, col)) & "-" ALPHA = ALPHA & K.Cells(3, col) & "-" t = t + 1 End If Next col If t > 1 Then With A.Cells(m, 4) .Value = Mid(ALL, 1, Len(ALL) - 1) .Offset(, 1) = Mid(ALPHA, 1, Len(ALPHA) - 1) .Offset(, 2) = t - 1 .Offset(, 3) = K.Cells(2, "Q") .Offset(, 4) = Year(Date) End With m = m + 1 End If My_next: t = 1 ALL = " ": ALPHA = " " Next i Application.Calculation = xlCalculationAutomatic End Sub الملف مرفق Tarhil_3iyab.xlsm

تفضل هذا التعديل اخي الكريم تم اضافة تنسيقات شرطية حتما ستنال اعجابك اربعة الوان ابيض = ليس لديه اشتراك اخضر = لديه اشتراك اكثر من خمسة ايام ازرق = لديه اشتراك يساوي او اقل من خمسة ايام احمر = لديه اشتراك منتهي GYM.accdb

أخي RAGABFAROUK لطالما نصحنا أساتذتا بهذا المنتدي الكريم بتقسيم البرنامج الي واجهات وجداول أي تكون النماذج والاستعلامان والتقارير بقاعدة بيانات مستقلة وتكون الجداول بقاعدة أخري ويتم الربط بينهما -- تفاديا لمثل هذه المشكلات وكذلك الاحتفاظ بالنسخة الأصل قبل الحفظ بصيغة الــ ACCDE وكذلك أخذ نسخة أحتياطية من البرنامج كل فترة زمنية قريبة يخفف كثيرا من الاضرار الناجمة عن هذا العطل وفي النهاية أسأل الله أن يجيرك في مصابك ويخلف عليك خيرا منه وأرجو أن يكون المرفق به شئ مما ترجو الحصول عليه فهذا كل ما استطعت انقاظه لك DR_ELLABBAD_fixed.rar

السلام عليكم مرفق ملف يشرح داله subtotal subtotal.rar

العامود D اجعله فارغاً من كل شيء نفذذ هذا الماكرو Sub tarheel22() Dim myrange1 As Range Set myrange1 = Sheets("Sheet1").Range("E3:G4") Sheets("Sheet1").Range("a3").CurrentRegion.Clear Sheets("Mydata").Range("A3:C500").AdvancedFilter _ xlFilterCopy, myrange1, Sheets("Sheet1").[a3] End Sub الملف مرفق Salim_222.xlsb

حرب هذا الماكرو Option Explicit Sub get_my_studiants() Application.ScreenUpdating = False Dim A As Worksheet Dim B As Worksheet Set A = Sheets("ALL_STD") Set B = Sheets("B") Dim col%, r, x, LB LB = B.Cells(Rows.Count, "B").End(3).Row If LB < 5 Then LB = 5 B.Range("a5").Resize(LB - 4, 6).Clear Dim my_clas$: my_clas = B.Range("e2") Dim my_mad$: my_mad = B.Range("K2").Value If my_clas = "" Or my_mad = "" Then GoTo Exit_Sub col = A.Rows(1).Find(my_clas, lookat:=1).Column r = A.Columns(1).Find(my_mad, lookat:=1).Row x = Application.CountIf(A.Columns(1), my_mad) B.Range("b5").Resize(x).Value = _ A.Cells(r, 2).Resize(x).Value B.Range("c5").Resize(x, 3).Value = _ A.Cells(r, col).Resize(x, 3).Value With B.Range("A5").Resize(LB - 4, 6) .Columns(1).Formula = "=if(B5="""","""",max($A$4:a4)+1)" .Columns(1).Interior.ColorIndex = 6 .Borders.LineStyle = 1 .Columns(6).Formula = "=RANK(E5,$E$5:$E$29,0)+COUNTIF($E5:E$5,E5)" .Value = .Value .Font.Size = 26 .Font.Bold = True .InsertIndent 1 End With Exit_Sub: Application.ScreenUpdating = True End Sub الملف مرفق My_students.xlsm

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

السلام عليكم اخي العزيز يوجد بالموقع الكثير من برامج الصادر والوارد / استخدم خاصية البحث هذا برنامج صادر ووارد للاخ / محمد علي الطيب وهو برنامج جميل جدا مفتوح المصدر تحياتي برنامج_الصادر_والوارد.rar

لا أعلم اذا كان هذا المطلوب Leave_book.xlsx

السلام عليكم ورحمة الله وبركاته زملائي وأخوتي الأفاضل محاولة مني بعمل فورم بحث وإضافة وتعديل في كل أوراق العمل اختيار اسم ورقة العمل عن طريق كمبوبوكس بعد ذلك متاح لك البحث والإضافة في اسم ورقة العمل المختارة كل الليبل التي أمام التكست بوكسات التي يوضع فيها البيانات التي سوف سيتم إضافتها أو ترحيلها تأخذ اسماءها من الصف الخامس من ورقة العمل النشطة في حالة إذا تم فتح الفورم وإليكم الملف فورم بحث وإضافة وتعديل في كل أوراق العمل.xlsm

لا أعلم اذا كان هذا المطلوب Tekrar.xlsx

شاهد المرفق الكود Function RESULTA(rng As Range) As String Application.Volatile Dim c As Integer Dim r As Integer Dim str As String Dim subj As String c = rng.Column r = rng.Row subj = Cells(2, c - 3).Text str = "راسب في مادة " & subj & " " If Cells(r, c) = "غ" Then str = str & "بسبب غيابه في العملي و" If Cells(r, c + 1) = "غ" Then str = str & "بسبب غيابه في التحريري و" If Cells(r, c) < Cells(9, c) Then str = str & "لعدم حصوله علي ربع الدرجة في العملي و" If Cells(r, c + 1) < Cells(9, c + 1) Then str = str & "لعدم حصوله علي ربع الدرجة في التحريري و" If Cells(r, c + 2) < Cells(9, c + 2) Then str = str & "لعدم حصوله علي ربع الدرجة في الكلية و" str = Left(str, Len(str) - 2) If Len(str) < 20 Then str = "ناجح" RESULTA = str End Function المصنف1.xlsm

اليك الحل Employee Data - 2015salim.rar

تفضل أستاذ حمدي .. يا بختك بموضوعك هذا حل آخر بالكود مشابه لحل الأستاذ الكبير أبو تراب (مع إمكانية أن يكون المدى مطاطي أي غير ثابت Dynamic) Distinct Validation List Across Columns.rar

السلام عليكم إخوتي الاحبه أعضاء وأساتذة منتدانا الغالي أقدم كود يقوم بالبحث في سلسلة نصيه ويستخرج ( الكلمات العربيه - والكلمات الانجليزي - والأرقام ) وكل سلسلة في عمود المدى الإفتراضي عمود "A" أرجو التجربه إن وجدت اي ملاحظات أو أخطاء Public Sub Cnvrt_Ali() Dim L_A&, i& On Error Resume Next ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\System32\vbscript.dll\3" On Error GoTo 0 With ActiveSheet L_A = .Cells(.Rows.Count, "A").End(xlUp).Row For i = 2 To L_A .Range("B" & i).Resize(1, 3).Value = S_Nm_Ali(.Range("A" & i).Value) Next i End With End Sub Private Function S_Nm_Ali(ByVal Nms As String) Dim E$, A$, Nm$ Dim V_r As Object Set V_r = CreateObject("VBScript.Regexp") On Error Resume Next With V_r .Global = True .IgnoreCase = True .Pattern = "\w|\n|\-|\(|\)|\&|\." A = Trim(.Replace(Nms, "")) .Pattern = "\D+" E = Trim(.Replace(Nms, "")) .Pattern = "[-?\d+(\.\d+)?|\u0600-\u06FF]" Nm = Trim(.Replace(Nms, "")) End With S_Nm_Ali = Array(A, E, Nm) Set V_r = Nothing End Function Ali_String.rar

السلام عليكم و رحمة الله وبركاته اخي ولد مكة معذور على التأخير طبعا مكة الله يعمرها هذه الأيام زحمة لأبعد حد الله يعينكم ويتقبل منكم وكما ذكر اخي الحبيب مصطفى كمال الذي اعتبره انا واحد من كبار العارفين للتعامل بالدوال لا تستخدم الدالة dATEDIF هنا ولكن قم بعملية الطرح مباشرة = = = = و في المرفق قمت بعمل تعديل للتاريخ كـ التالي اذاكانت الغرفة بها تاريخ دخول و خروج - يحسب لك الأيام الى تاريخ الخروج اذاكانت الغرفة لها تاريخ دخول و ليس لها تاريخ خروج - يحسب لك الأيام حتى تاريخ اليوم اذاكان الغرفة ليس لها تاريخ دخول ولا تاريخ خروج يعطيك صفر شاهد المرفق ولدمكة.rar

كلام ناس كبار وما عليه أي غبار وعشان نكمل المشوار دي كمان فكرة في نفس الإطار وإن شاء الله ما يكونش فيها تكرار لما تفضلتم به يا أساتذة من روائع الأفكار وزمان علمونا إن التكرار كمان بيعلم الشطار ياربي احفظ علينا أخوتنا وثبت اقدامنا على هذا المسار مع حبي وتقديري أخوكم أبو عبدالله تعيين نطاقة الطباعة نهاية صفه بنص بالنطاق.rar