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

جرب هذا ........................ Sub CleanAndRemovePatterns() Dim db As DAO.Database Dim rs As DAO.Recordset Dim strPattern As String Dim strInput As String Dim updatedText As String Dim regExp As Object On Error GoTo ErrorHandler Set db = CurrentDb Set rs = db.OpenRecordset("SELECT ID, nass FROM book", dbOpenDynaset) strPattern = "&\d+&&" Set regExp = CreateObject("VBScript.RegExp") regExp.Pattern = strPattern regExp.Global = True Do While Not rs.EOF If Not IsNull(rs!nass) Then strInput = rs!nass updatedText = strInput If regExp.Test(updatedText) Then updatedText = regExp.Replace(updatedText, "") End If If Left(updatedText, 2) = vbCrLf Then updatedText = Mid(updatedText, 3) ElseIf Left(updatedText, 1) = vbLf Then updatedText = Mid(updatedText, 2) ElseIf Left(updatedText, 1) = vbCr Then updatedText = Mid(updatedText, 2) End If updatedText = LTrim(updatedText) If strInput <> updatedText Then rs.Edit rs!nass = updatedText rs.Update End If End If rs.MoveNext Loop rs.Close Set rs = Nothing Set db = Nothing Set regExp = Nothing MsgBox "تمت إزالة الأنماط والسطر الفارغ بنجاح!", vbInformation Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical If Not rs Is Nothing Then rs.Close Set rs = Nothing End If Set db = Nothing Set regExp = Nothing End Sub

اسمحوا لي مشاركتكم ،، فقد أعجبت بالفكرة استناداً إلى ملف الأستاذ @Moosak ، وإن سمح لي بالتعديل عليه لتوليفه حسب حاجة أخونا @Mr-X التعديلات بسيطة الى حد ما ، ولكنها لبت المطلوب في المرفق التالي DBSize.accdb

وعليكم السلام ورحمة الله تعالى وبركاته Sub MergeTotal() Dim WS As Worksheet, crWS As Worksheet, LastRow As Long, Irow As Long On Error Resume Next Set crWS = Sheets("total") On Error GoTo 0 If crWS Is Nothing Then MsgBox " غير موجودة total ورقة ", vbInformation Exit Sub Else Application.ScreenUpdating = False crWS.Range("A2:O" & crWS.Rows.Count).Clear End If Irow = 2 For Each WS In ThisWorkbook.Sheets If WS.Name <> crWS.Name Then LastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If LastRow >= 2 Then WS.Range("A2:O" & LastRow).Copy crWS.Cells(Irow, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme Irow = crWS.Cells(crWS.Rows.Count, 1).End(xlUp).Row + 1 End If End If Next WS Application.CutCopyMode = False Application.ScreenUpdating = True End Sub or Sub MergeTotal() Dim WS As Worksheet, Src As Worksheet Dim OnRng As Variant, rng As Range, r As Range Dim lastRow As Long, tmp As Long, col As Integer Set WS = Sheets("total") Application.ScreenUpdating = False lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row If lastRow > 1 Then: WS.Rows("2:" & lastRow).Clear tmp = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1 For Each Src In ThisWorkbook.Sheets If Src.Name <> WS.Name Then OnRng = Src.Range("A2:O" & Src.Cells(Src.Rows.Count, "A").End(xlUp).Row).Value WS.Cells(tmp, 1).Resize(UBound(OnRng, 1), UBound(OnRng, 2)).Value = OnRng For lastRow = 1 To Src.Cells(Src.Rows.Count, "A").End(xlUp).Row WS.Rows(tmp + lastRow - 1).RowHeight = 18.5 Next lastRow tmp = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1 End If Next Src With WS.Range("A1:O" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row) .Borders.LineStyle = xlContinuous: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With Application.ScreenUpdating = True End Sub الرواتب.xlsb

السلام عليكم السكانر الخاص بي هو ايبسون 1630 وللاسف الملف الذي انزلته انت لم يعمل مع الفيدر يعمل فقط مع العدسة

الليلة في وقت متأخر إن شاء اللهز

وعليكم السلام يمكنك استخداد معادلة المصفوفة التالية (Ctrl+Shift+Enter) =INDEX(الاستحقاق!$D$2:$D$12,MATCH(1,IF($B2>=الاستحقاق!$B$2:$B$12,IF($B2<=الاستحقاق!$C$2:$C$12,IF($E2=الاستحقاق!$A$2:$A$12,1))),0)) معادلة بشروط1.xlsx

معادلة معرفة المتبقي من الأيام: تاريخ انتهاء المستنيد - Today()

شكر وتقدير اخى الكريم

طريقة عمل الكومبوبوكس انك بمجرد ماتكتب فيها بيقوم بالبحث وبيظلل الكتابه انا مش عاوز ال dropdown الوضع اختلف حقيقي مع ويندوز ١١ ومش عارف ليه وكمان انا بستخدم تابليت ديل فؤجئت كمان ان الكىيبورد اللى في الشاشه مش بتتحرك من مكانها ثابته فى اسفل الشاشه بعكس ويندوز ١٠ على العموم كانت تجربه اكثر من سيئه مع ويندوز ١١ وتم الرجوع بفضل الله لويندوز ١٠ ولا انصح احد بويندوز ١١ عن تجربه

استاذ @TAMER AGOOR❤️🌹 اذا كان المتغير لكل تقرير انتظر ثانية اما اذا كان التغير مره واحده فتح التقرير مباشر النص من اعلى الى اسفل ================================= بس مو مقتنعه محتاج دالة او كود تصور نموذج بوضع النموذج مخفي Change_Text_Up_To_Dawon_V1.rar

تفضل ..... الكود لنقل الرقم فقط ...اعلمنا بالنتيجة .... Sub ExtractSingleNumber() Dim db As DAO.Database Dim rs As DAO.Recordset Dim strPattern As String Dim strInput As String Dim regExp As Object Dim matches As Object ' النمط لاستخراج الرقم بين & و && strPattern = "&(\d+)&&" ' تهيئة قاعدة البيانات Set db = CurrentDb Set rs = db.OpenRecordset("SELECT nass, page FROM book") ' تهيئة كائن التعبير النمطي Set regExp = CreateObject("VBScript.RegExp") regExp.Pattern = strPattern regExp.Global = False ' المرور عبر السجلات Do While Not rs.EOF strInput = rs!nass If regExp.Test(strInput) Then Set matches = regExp.Execute(strInput) rs.Edit rs!Page = matches(0).SubMatches(0) ' الرقم المستخرج rs.Update End If rs.MoveNext Loop ' تنظيف الموارد rs.Close Set rs = Nothing Set db = Nothing Set regExp = Nothing MsgBox "تم نسخ الأرقام إلى الحقل page بنجاح!" End Sub والكود التالي لحذف السطر الذي به النمط تفضل ...... Sub RemoveAllPatterns() Dim db As DAO.Database Dim rs As DAO.Recordset Dim strPattern As String Dim strInput As String Dim regExp As Object ' النمط لإزالة كل ما يشبه &رقم&& strPattern = "&\d+&&" ' تهيئة قاعدة البيانات Set db = CurrentDb Set rs = db.OpenRecordset("SELECT nass FROM book") ' تهيئة كائن التعبير النمطي Set regExp = CreateObject("VBScript.RegExp") regExp.Pattern = strPattern regExp.Global = True ' لضمان إزالة جميع التطابقات داخل النص ' المرور عبر السجلات Do While Not rs.EOF strInput = rs!nass If regExp.Test(strInput) Then rs.Edit ' إزالة جميع التطابقات للنمط من النص rs!nass = regExp.Replace(strInput, "") rs.Update End If rs.MoveNext Loop ' تنظيف الموارد rs.Close Set rs = Nothing Set db = Nothing Set regExp = Nothing MsgBox "تم حذف جميع الأنماط &رقم&& بنجاح!" End Sub

مرحبا بكم اخوتي في هذا المنتدى الرائع بكل المقاييس💖 ولكي لا اطول عليكم بالكلام😎 : حبيت استفسر عن امكانية شرح (ربط الاكسس ببرنامج سهل جدا يكون الملف exe ويقرا الناتج من الويندوز مباشرة من غير ما يحتاج الى وجود الاكسس), في هذا المنتدى يعني بالمعنى الاصح تعطيه لعميل او لمجموعة اشخاص ماكو اي مشكلة لانه exe . او اي مشاكل اخرى ينتج من الاكسس 🙏 و الصراحة انا صار لي يومين استعمله 😅 والان انشات برنامج بسيط جدا جدا يحتوي على نموذجين الاول للادخال البيانات الى الاكسس طبعا عن طريق ربطها بطريقة المعالج بسيطة جدا , وتكوين ازرار التحكم من اظافة و حذف و غلق و التالي و السابق و الخ من الازرار مع امكانية اظافة الصور تحددها من مكان و تجلبها الى الفورم و يرتبط بها خارجيا , وايظا كونت استعلام في الاكسس😀 و عرضتها في الفورم الثاني و طلعت لي النتائج بكل سلاسة , وايظا ازرار الامر للتنقل بين النمودجين , ولا ننسى انه يقوم بانشاء التقارير ايظا ولكنني لم استعملها لحد الان من شدة فرحتي انا ارى لحد الان ان البرنامج يستاهل التجربة عليه , وطبعا لا ننسى رأي السادة المشرفين و الاداريين لكي لا اتعدى على قوانين المنتدى الرائع و العظيم , اذا ما ارادوا ان انشر بعض المعلومات عنه تحياتي لكم

دولفي = الباثيون Open Source K انت محتاج تأمين على البيانات صحيح و البرمجة الاخرى مثل الفيجوال EXE يعتبرغير مشروع لاحتمال الشبة كتابتك للكود بسطر عقابي او سطر انتقامي للعملاء تسجن بالعقد لا تلغم مشروع العميل يكفي موجب العقد فية اشتراطات وتأمين وجزاء ( بوفاء تسليم كما ينبغي ) ========================== ك فكره يمكن التعامل مع EXE تصميم برنامجين 1- تثبيت البرنامج 2- تشغيل ملف القاعدة - اكواد التحقق انت بنشوف بدل لنك اختصار مباشر اكسس بتشوف اختصار فيجوال ثم يفتح القاعده شرح اليوزر للويندوز كيف تخفي الهارد ديسك وتغلق الصلاحيات الوندوز لليوز الفرعي للويندوز مع تشغيل الملفات والهارد مخفي من الويندوز كان F D A (BE) اختصار والافضل وحدات تخزين او سيرفرات محلية - اذا كان وحدات تخزين حديثة فيها من الجهاز تشفير عالي ونسخ احتياطية تلقائية اقوى بمراحل من جهاز الكمبيوتر غير توفير الانترنت كسحابة سريعة استاذ @gavan❤️🌹 اتمنى لك التوفيق ولا تنسى راح ترجع "Web" له طريج واعتذر يمكن اكون غلطانه

لم يعمل السكنر معي ايظا!! هل من الممكن المشكلة تكمل في عدم وجود ملف twin. Dll في مجلد الويندوز؟؟ 🌹🌹

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

شكرا اخي Foksh تعديلات ع ملف الاكسس تم عمل تعديلات ع بعض الدوال لضامن اداء افضل مع تعدد الاجهزه https://drive.google.com/drive/folders/1D2EMCe5fVybdrrzPWZT57uKNcTQbwMx7?usp=drive_link FinalTestZatca-v1.2.rar

أهلا بك @gavan أراك تمردت على أكسس وأنشققت عنه وتحزبت إلى دولفي!.. أود إحاطتك علما أن لك زملاء سبقوك إلى دلفي من أبرزهم الأستاذ @صالح حمادي يمكنك مراسلته على الخاص فلربما يظهر على أيديكما قسم جديد! اسمه منتدي الدلفي!😁

شكرا اخي الحبيب ابو خليك اخوتي البرنامج هو الديلفي Delphi وانا استخدم النسخة 11, لمن يريد ان يستخذم النسخة هنا وهي غير مجانية , تجد مع النسخة الكراك و التفعيل https://downloaddevtools.com/en/product/1/free-download-embarcadero-rad-studio-10-4-sydney ولكي لا اطول عليكم قمت بتصوير كل حركة قمت بها اثناء استعمال البرنامج , و للشرح بقية , ولكم مني اجمل شكر وهذه هي النتيجة في الصورة

اداة البحث هذه قمت بمحاولة تجميع الافكار فيها بعناية وبترتيبها لمحاولة الوصول الى اقصى درجات الكفائة والمرونة الممكنة اولا : تعرية وتطهير النص والتحكم فى ذلك حسب الحاجة كما سبق التنويه عن هذه الجزئية فى هذا الموضوع ثانيا : التحكم فى اعداد مصادر البيانت :- (مصدر البيانات"جدول /استعلام" - الحقولالبحث المخصصة - امكانية اضافة حقل او اكثر يعتمد على تطهير النصوص ثالثا : آلية البحث بحيث يمكن البحث من خلال ( الكلمة تبدأ بـ - تنتهى بـ - يتضمن الكلمة فى امكان - او متطابق تماما او لو عدد الكلمات كثير يمكن كتابة جزء من كل كلمة فى نفس السجل ولا يشترط الترتيب ) مثال : نريد البحث فى السجل قيمة هذا السجل : 26675 فوزي عبد الحميد ابو الفتوح محمد سعده لو تم اختيار من إعدادت البحث : يحتوى على اكثر من كلمة او جزء من كلمه يفصل بينهم مسافة من إعدادت البحث ثم كتبنا فى مربع البحث : عب فت سع 66 نحصل على النتيجة اثناء كتابة الكود تم عمل جدول باسم : tblSearchSettings بحيث يتم حفظ الاعدادت الخاصة بعملية البحث والفرز والتصفية تم وضع القيم الافتراضية لاجراء عمليات البحث والفرز والتصفية المتعددة على اكمل وجهة فى حالة حذف الجدول الخاص باعدادت البحث كما انها تمثل مرونة قصوى لكل مستخدم على حدى فى حالة استخدام شبكة محلية يستطيع كل مستخدم الاحتفاظ بالاعدادت التى تناسبه دون التأثير على الاخرين اخيرا المرفق واترككم مع التجربة Search Utility V 3.0.2.accdb

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

لكون ورقة البيانات في أكسل تحتوي على حقول كثيرة، أقترح عليك عمل ذلك عن طرق استخدام محرر الاستعلام في أكسس... وفقا للخطوات التالية الخطوة الأولى.. قم بتغيير الدليل الإفتراضي لأكسس لكي يشير إلى دليل قاعدة البيانات الحالية، كما في القصاصة التالية الخطوة الثانية.. نكون جملة استعلام للاتصال بورقة البيانات ومن ثم نوقوم بحفظه، كما في القصاصة التالية الخطوة الثالثة: ننشىء استعلام تحديث بيانات بين جدول البيانات وبين استعلام الاتصال الذي أنشأناه في الخطوة السابقة، مع مراعات العلاقة بين هذين المصدرين (جميع البيانات من استعلام بيانات أكسل، والبيانات التي تقابها من جدول بيانات الموظفين).. العلاقة بهذه الصورة تسمح بتحديث جدول بيانات الموظفين إذا كانت اليانات موجودة مسبقا، كما تسمح باضافة البيانات الجديدة.. أنظر القصاصة التالية الخطوة الرابعة.. اختيار الحقول المطلوب تحديثها كما في القصاصة التالية (إصدار الأكسس لدي يدعم التحرير الذكي) الخطوة الأخيرة نغير الشفرة تحت زر الأمر لتصبح كالتالي Private Sub CMD_UPDATE_Click() '-- تعطيل رسائل التحذير DoCmd.SetWarnings False '-- تشغيل استعلام مزامنة البيانات DoCmd.OpenQuery "[مزامنة البيانات]" '-- تفعيل رسائل التجذير DoCmd.SetWarnings True '-- إعادة تنشيط جدول بيانات الموظفين Me.Child0.Requery End Sub ملاحظة مهمة.. ورقة البيانات ليس فيها بيانات! ولذا عند تشغيل استعلام مزامنة البيانات سوف يرجع لنا رسالة خطأ بعدم مطابقة البيانات المرفق بعد التعديل.. tb_الموضفين.zip

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

عليكم السلام ورحمة الله وبركاته تفضل أخي الكريم Sub test() With Sheets("يومية الحضور والإنصراف").Range("B4:C" & Sheets("يومية الحضور والإنصراف").Cells(Rows.Count, 1).End(xlUp).Row) .Formula = "=IFERROR(VLOOKUP($A:$A,Table9,COLUMN(),0),"""")" .Value = .Value End With With Sheets("رصيد الأجازات").Range("B3:D" & Sheets("رصيد الأجازات").Cells(Rows.Count, 2).End(xlUp).Row) .Formula = "=IFERROR(VLOOKUP($A:$A,Table9,COLUMN(),0),"""")" .Offset(, 3).Resize(, 1).Formula = "=IFERROR(IF(DATEDIF([@[تاريخ التعيين]],$D$1,""D"")/30>3.1,""يستحق"",""""),"""")" .Offset(, 5).Resize(, 1).Formula = "=IF([@[معادلة الرصيد]]=""يستحق"",$O$1+[@[معالجة الرصيد]],0)" .Offset(, 6).Resize(, 1).Formula = "=[@[الرصيد المرحل]]+[@[رصيد 2023]]" .Offset(, 7).Resize(, 1).Formula = "=(COUNTIFS('يومية الحضور والإنصراف'!$A:$A,$A3,'يومية الحضور والإنصراف'!$H:$H,""أجازة"")+(COUNTIFS('يومية الحضور والإنصراف'!$A:$A,$A3,'يومية الحضور والإنصراف'!$H:$H,""أجازة مجمعة"")))" .Offset(, 8).Resize(, 1).Formula = "=(COUNTIFS('يومية الحضور والإنصراف'!$A:$A,$A4,'يومية الحضور والإنصراف'!$H:$H,""أجازة عارضة""))" .Offset(, 9).Resize(, 1).Formula = "=IF(E3=""يستحق"",$N$1-[@[ عارضة]],0)" .Offset(, 10).Resize(, 1).Formula = "=(([@[إجمالي الرصيد المستحق]]-([@[ سنوي]]+[@[ عارضة]]+[@[تسوية نقدي]])))-[@[باقي رصيد العارضة]]" .Offset(, 11).Resize(, 1).Formula = "=([@[باقي رصيد السنوي ]]+[@[باقي رصيد العارضة]])" With .Resize(, 12) .Value = .Value End With End With End Sub

ملف لتوزيع اللجان طباعـــــــــــــه صفحات.rar استدعاء بيانات بطريقه سريعه جدا ''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''' Sub DOR_tan() ''هذا الكود للعبقري ياسر العربي حفظه الله '' تم هذا الكود بتاريخ 8 / 10/ 2016 ''الهدف من الكود هو فلترة البيانات ''شرح الكود '' Dim myArray, lr, X, targt, targt1, targt2, targtN Dim SERCH As Worksheet, DATA As Worksheet '____________________________________________ Set DATA = Worksheets("رصد الترم الثانى") 'اسم شيت المصدر Set SERCH = Worksheets("كشف الدور الثاني") 'اسم الشيت الهدف '____________________________________________ Range("A8:R1000").Clear 'النطاقات متغيره Range("B7:R7").AutoFill Destination:=Range("B7:R" & Range("A4").Value + 6), Type:=xlFillDefault lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row + 2 'اخر صف به بيانات 'رقم عمود البدايه اللي بعد المسلسل ' متغير SERCH.Range("C7:N" & SERCH.Cells(Rows.Count, 3).End(xlUp).Row + 1).ClearContents 'مسح نطاق البحث القديم targt = "له* دور ثان في" 'معيار البحث 'نطاق قاعدةالبيانات المصدر الذي سيتم البحث فيه myArray = DATA.Range("A7:EF" & lr) '____________________________________________ 'عدد الاعمده في الجدول في صفحه الهدف ReDim y(1 To lr, 1 To 13) For X = 1 To lr - 6 If targt = "" Then Exit Sub 'رقم عمود معيار البحث If myArray(X, 101) Like targt & "*" Then rw = rw + 1 'For ww = 1 To 102 ' Y(rw, ww) = myArray(X, ww) ' Next ww 'العمود التاني بعد المسلسل y(rw, 1) = myArray(X, 2) 'العمود الثالث بعد المسلسل y(rw, 2) = myArray(X, 3) 'العمود الرابع بعد المسلسل y(rw, 3) = myArray(X, 13) 'العمود الخامس بعد المسلسل y(rw, 4) = myArray(X, 22) 'العمود السادس بعد المسلسل وهكذا y(rw, 5) = myArray(X, 31) y(rw, 6) = myArray(X, 40) y(rw, 7) = myArray(X, 51) y(rw, 8) = myArray(X, 52) y(rw, 9) = myArray(X, 82) y(rw, 10) = myArray(X, 101) y(rw, 11) = myArray(X, 102) ' Y(rw, 12) = myArray(X, 110) ' Y(rw, 13) = myArray(X, 111) End If Next X If rw > 0 Then SERCH.Cells(Rows.Count, 3).End(xlUp)(2, 1).Resize(rw, 13).Value = y() End Sub استدعاء بيانات بطريقه سريعه.rar

استدعاء بيانات بطريقه سريعه جدا للحبيب ياسر العربي خليفه العلامه عبد الله باقشير استدعاء بيانات بطريقه سريعه.rar