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

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

ههههه نعم لذا انا كتبت ومنها :- ولم اكتب وهي :- ماشاء الله مركز صح 🌹

مشاركة مع استاذي الفاضل @jjafferr يمكن الوصول لاذونات المستخدمين في كافة اصدارات اكسس اذا تنسيق القاعدة بصيغة mdb او mde واذا كانت القاعدة باصدار احدث من 2003 يمكن تحويلها للاصدار 2003 بشرط الا تكون تستخدم مميزات الاصدارات الاحدث من 2003 ومنها حقل نوع البيانات محسوب نوع البيانات مرفق حقول بحث متعددة القيم حقل من نوع رقم كبير وللوصول الى الاذونات في الاصدارات الحديثة بعد تحويل الملف نفتحة فتح خاص ثم معلومات

تفضل جرب المرفق الشرح والتفاصيل بالداخل حجم السائل 1 في اسطوانة أفقية.xlsx

استاذه @نيفين محمد 2021 لما لم تستخدمى طريقه استاذ @أبو إبراهيم الغامدي ومثلها الطريقه الاخرى لاستاذ جعفر الذى تم وضع رابطها لك من استاذ محمد الحلوانى ؟ فهذه الطرق ايسر جربى الطريقه قومى بالخطوات لاستاذ جعفر المذكوره بالرابط واليكى الرابط مره اخرى بالتوفيق

لعدم اهدار واضاعة وقت الأساتذة دون جدوى أو أهمية ... فلا تنتظر المساعدة من احد بدون رفع ملف مدعوم بشرح كافى عن المطلوب , فلايمكن العمل على التخمين ... فاذا تخيلت ما تريد هل ينفع معك هذا الكود , وان لم يصلح معك فكما اخبرتك أدى هذا بدوره الى اضاعة الوقت دون جدوى Private Sub UserForm_Initialize() Dim MyData As Range Dim r As Long With Me.ListBox1 .RowSource = "" Set MyData = Worksheets("Sheet1").Range("A2:j100") .List = MyData.Cells.Value For r = .ListCount - 1 To 0 Step -1 If .List(r, 3) = "" Then .RemoveItem r End If Next r End With End Sub

وتنسيقات النماذج والتقارير الجديدة 🙂 جعفر

وعليكم السلام 🙂 اذا استعملت صيغة mdb او mde ، فستجد هذا الخيار في جميع اصدارات الاكسس ، واما اذا استعملت صيغة accdb او accde ، فمايكروسوفت قامت بحذف هذه الخاصية ، ويمكنك البحث في المنتدى عن الطرق البديلة لاذونات المستخدمين 🙂 جعفر

تفضل .. اتمنى يكون هو مطلوبك Upالملاك 2021.rar

الطريقة السابقة تتعامل مع السجلات عبر النموذج جرب هذه الطريقة من خلال الجدول مباشرة Dim rst As dao.Recordset Set rst = CurrentDb.OpenRecordset("folllow") rst.MoveFirst Do Until rst.EOF If rst![رقم العملية] = Me![T4] Then MsgBox " السجل مكرر ", , " تنبيه" Me.Undo DoCmd.CancelEvent Exit Do End If rst.MoveNext Loop rst.Close F06.rar

وعليكم السلام 🙂 جعفر

جرب هذا الملف Option Explicit Sub One_by_one() Dim S As Worksheet Dim F_rg As Range Set S = Sheets("Salim") If S.Range("C2") = "" Then S.Range("C2") = 1 If S.Range("D2") = "" Then S.Range("D2") = "السبت" S.Range("B7").Resize(10, 2).ClearContents Select Case S.Range("C2") Case 1 Set F_rg = S.Range("B20:N20").Find(S.Range("D2"), lookat:=1) Case 2 Set F_rg = S.Range("B34:N34").Find(S.Range("D2"), lookat:=1) Case 3 Set F_rg = S.Range("B48:N48").Find(S.Range("D2"), lookat:=1) Case 4 Set F_rg = S.Range("B62:N62").Find(S.Range("D2"), lookat:=1) Case Else Exit Sub End Select If Not F_rg Is Nothing Then Range("B7").Resize(10, 2).Value = _ F_rg.Resize(10, 2).Value End If End Sub الملف مرفق Maliki.xlsm

المشكلة انه في الصفحة ميرنا 3 الصف الأول فارع (تم تعبئته والكود يعمل) الملف مرفق و لن أرد على اي سؤال يتعلق بنصميم الملف من جهة الصفوف الفارغة او التنسيق الذي لا يتناسب مع الكود الذي تم وضعه Yara_Last_file.xlsm

بل حتى اصدار 2016 البناء السابق لـ 16.0.7812 لايمكنة تشغيل البرنامج المعمول على اصدار 16 الاحدث مرورا بالاصدار 2019 اذا استخدمنا نوع حقل رقم كبير لمعرفة الاصدار والبناء للنسخة في اكسس 2019 في القائمة الجانية ندخل على الحساب ثم حول اكس تظهر لدينا معلومات النسخة الحالية نصيحة الخبراء بعمل البرنامج على اصدار اقل من 2013 اذا اردنا تشغيله على اصدارات مختلفة ليست من فراغ

وعليكم السلام ورحمه الله وبركاته اخى الفاضل هنا منتدى تعليمى ومساعده الاعضاء ع حلول المشاكل اثناء عملهم وتباددل الخبرات اذا اردت قم بوضع طلبك فى قسم الاعلانات بالموقع عالرابط التالى https://www.officena.net/ib/forum/157-إعلانات-شخصية-بأجر-للاعضاء/ بالتوفيق

اخى استاذ سليم حاصبيا تم حذف الصفوف العليا الفارغة بملفى ظهر ايضا نفس الخطأ معلش انا اسفة بس والله هذا ما حدث فى نفس السطر من الكود If Not F_rg Is Nothing And F_rg.Column <= Col Then بارك الله فيك اخى احتاج علاج نهائ لو امكن معلش انا عارفةسهلةعليك ان شاء الله ان اثق فيك تمام الثقة

اعتقد انها السبب في عدم فتح البرنامج المعمول على الاكسس 2019 ، بواسطة اكسس 2010 🙂 جعفر

اضافة الى الكود كما في الصورة (في المكان المناسب)

استبدلي الرقم 2 بالرقم 5 في هذا السطر For i = 2 To ro

أعيدي تحميل الملف ( لأنه طرأ تعديل بسيط عليه من الناحية الجمالية)

تعديل على الكود في الــ NO_arr ادخلت اسماء الشيتات التي لا أريدها لأن عدد الشيتات كبير (100) و بالتالي الأفضل ادخال الشيتات التي نريد استثناؤها Option Explicit Sub Get_Data() Dim Arr_SH(), t% Dim Arr_Number() Dim NO_arr, n% Dim x As Boolean Dim Special_SH As Worksheet Dim sh As Worksheet, My_sheet As Worksheet Dim ro%, Col%, m%, k%, i% Dim F_rg As Range NO_arr = Array("تقرير تجميعى", "تقرير2", "تقرير3", "تقرير4", _ "تقرير5", "تقرير6", "تقرير7") Set Special_SH = Sheets("تقرير تجميعى") Application.ScreenUpdating = False k = 1 For i = 1 To Sheets.Count x = IsError(Application.Match(Sheets(i).Name, NO_arr, 0)) If x Then ReDim Preserve Arr_SH(1 To k) ReDim Preserve Arr_Number(1 To k) Arr_SH(k) = Sheets(i).Name: Arr_Number(k) = k k = k + 1 End If Next i m = 2 Special_SH.Range("A1").CurrentRegion.Offset(1).Clear For t = LBound(Arr_SH) To UBound(Arr_SH) Set sh = Sheets(Arr_SH(t)) ro = sh.Cells(Rows.Count, 1).End(3).Row Col = sh.Cells(1, Columns.Count).End(1).Column For i = 2 To ro Special_SH.Cells(m, 2).Resize(, 2).Value = _ sh.Cells(i, 1).Resize(, 2).Value Set F_rg = sh.Cells(i, 2).Resize(, Col - 1). _ Find("*", after:=sh.Cells(i, 3)) If Not F_rg Is Nothing And F_rg.Column <= Col Then With Special_SH.Cells(m, 4) .Value = F_rg '+++++++++ By choise You can insert _ ' Sheets name or Sheet Number++++++++++++ ' .Offset(, 1) = Arr_Number(t) .Offset(, 1) = sh.Name '++++++++++++++++++++++++++++++++++ .Offset(, 2) = sh.Cells(1, F_rg.Column) .Offset(, -3).Resize(, 6).Interior.ColorIndex = _ IIf(n Mod 2 = 0, 24, 36) End With m = m + 1 End If Next i n = n + 1 Next t If m > 2 Then With Special_SH.Range("a2:f" & m) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 ' .Interior.ColorIndex = 35 .Columns(1) = Evaluate("row(1:" & m - 2 & ")") With .Rows(m - 1) .Cells(1) = vbNullString .Cells(5) = "Sum" .Cells(4).Formula = _ "=SUM(D2:D" & m - 1 & ")" .Interior.ColorIndex = 40 .Value = .Value End With End With End If Application.ScreenUpdating = True End Sub الملف مرفق Yara_2.xlsm

السلام عليكم وهذا حل باستعمال المعادلات... Book2.xlsx

ادراج اسماء الصفجات في Array يجب ان يكون بالضيط كتا هو اسم البشيت (دون مسافة زائدة او ناقصة) مثلاً اذا كان اسم الشيت اوفيسنا لا يجوز في الـــ كتابة اوفـــيسنا اذا كان اسم الشيت ِABC لا يجوز في الـــ كتابة A BC الأفضل نسخ اسم الشيت ولصقه في Array

السلام عليكم ورحمة الله اربط هذا الكود بالزر الموجود بالورقة الشهادة Sub PrintCall() Dim ws As Worksheet, Sh As Worksheet, Rng As Range Dim LR As Long, i As Long, p As Long Dim x As Integer, WF As Variant Dim Nam, Sm Set ws = Sheets("بيان") Set Sh = Sheets("شهادة") Set WF = WorksheetFunction LR = ws.Range("B" & Rows.Count).End(3).Row Set Rng = ws.Range("A2:C" & LR) p = 2 x = Sheet6.Shapes("Spinner 3").ControlFormat.Value i = (x - 1) * 4 + 1 Do While p <= 32 Sh.Range("H" & p) = i Nam = WF.VLookup(i, Rng, 2, 0) Sh.Range("C" & p + 2) = Nam Sm = WF.VLookup(i, Rng, 3, 0) Sh.Range("H" & p + 2) = Sm p = p + 10 i = i + 1 Loop ActiveSheet.PrintOut From:=1, To:=1, Copies:=1 End Sub

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

او حتى جداولك العادية ، اذا كنت تحذف الكثير من بياناته. جعفر

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

استاذ/ Ali Mohamed Ali اشكر حضرتك ورأيك وسام على صدري ورجاء رجاء تصفحه واخبار بعيوبه لعلى أتمكن من تفاديها

المعادلة المطلوبة في هذه الصورة

بما انك لم ترفع ملف نمودج عما تريد اليك هاذا الشيء ربما تستفيذ منه listC.xlsm

وعليكم السلام ورحمة الله وبركاته والله حقيقة بعد هذه الردود لا يصلح رد آخر ولكن بدأت بكتابة الرد وانشغلت ببعض الأمور فلا مانع من مشاركة الاساتذة بالأجر بامكانك أن تغيري اعدادات الأمان من اعدادت الاكسس اتبعي الخطوات بالرابط التالي اما وان كان لا بد من استخدام آداة فاليك هذا الاسكربت لتخفيض امان الأكسس. وان لم يعمل بشكل جيد انظر الي الشرح بالفديو لتعديل الكود بالاسكربت وفقا لمسار الرجستري الخاص بالاصدار 2019 فالاصدار لدي 2016 أما عن طريقة أستاذنا أبوابراهيم الغامدي في الأفضل ولا شك لكون البرنامج يعمل بأمان ولا ننزع أمان الأكسس عنه وهذا الرابط لأستاذنا جعفر ينفذ طريقة أستاذ أبو ابراهيم ولكن عن طريق الكود واعتذر عن الاسهاب في الرد LowScuerity.rar

أكسس ليس بحاجة إلى أن تزعي عنه الأمان أو تخفضيه! أكسس بحاجة إلى أن تمنحيه مكاناً آمن ليعمل منه بحرية! أكسسي منحته الحرية الكاملة للعمل من أي مكان على حاسبي بهذه الطريقة..

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

وتفضل أخي المرفق السابق + دالة معرفة إستخراج رقم من نص بالمعادلات مع دالة معرفة.rar

السلام عليكم Option Explicit ' بسم الله الرحمن الرحيم " ' ********************* " ' دالة استخراج النص او الارقام " '==============================================" ' False = مهمل او Kh_Number اذا كان " ' تقوم باستخراج النص " ' True = Kh_Number اذا كان " ' تقوم باستخراج الارقام " '==============================================" '----------------------------------------------------------------- Function Kh_Replace_Text(ByVal Kh_Sub As String, Optional Kh_Number As Boolean) Dim Num As Byte, C As Integer Dim Sn As String, Re As String, Md As String Sn = Trim(Kh_Sub) For Num = 0 To 9 Sn = Replace(Sn, Num, "") Next Num If Kh_Number Then Re = Trim(Kh_Sub) Do While C < Len(Trim(Sn)) C = C + 1 Md = Mid(Sn, C, 1) Re = Replace(Re, Md, "") Loop Kh_Replace_Text = CDbl(Re) Else Kh_Replace_Text = Trim(Sn) End If End Function دالة استخراج النص او الارقام.rar

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