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

السلام عليكم ورحمة الله وبركاته بسم الله والحمدلله والصلاه والسلام على من لا نبى بعده سيدنا وامامنا وقائدنا وشفيعنا محمد صل الله عليه وعلى آله وصحبه وسلم تسليما كثيرا درس اليوم بسيط جدا ومهم وقد اتعبنى هذا الفرق كثيرا الى ان رايت هذا الفيديو واردت مشاركتكم المعلومه للاستفاده والاستذاده من اخوانى واساتذتى جزاهم الله عنا كل خير وانول بهذا دعوه صالحه لى ولجميع اخوانى واساتذتى جزاهم الله خيرا وحتى لا اكون ممن كتم علما هذا الدرس لايضاح الفرق فى استخدام النقطه . و علامة التعجب ! ومرفق مثال للتوضيح اكثر مثلا الكود التالى سوف يعرض رساله وبها اسم النموذج Private Sub btnNFrm_Click() MsgBox Me.name End Sub وهذا الكود سوف يعرض القيمه بالحقل Private Sub btnName_Click() MsgBox Me!name End Sub والفيديو تقبلوا تحياتى new.accdb

عليكم السلام، تفضل: Option Compare Database Private Sub go_Click() 'check if TextBox tn is empty If IsNull(tn) Then MsgBox "يرجى كتابة رقم للبحث عنه", vbCritical, "عملية خاطئة" Exit Sub End If 'check if record exist If DCount("ID", "tbl2", "HNO =" & tn) = 0 Then MsgBox "لم يتم العثور على السجل المطلوب", vbCritical, "عملية خاطئة" Exit Sub End If 'go special record Me.Recordset.FindFirst "HNO=" & tn 'clear TextBox tn after search tn = Null End Sub Private Sub tn_KeyDown(KeyCode As Integer, Shift As Integer) 'Do event when click Enter key. If KeyCode = vbKeyReturn Then Call go_Click End If End Sub لا تنسى اختيار أفضل أجابة لإغلاق الموضوع. تحياتي. انتقال.accdb

تفضل انا غيرت الحقل الى مربع تحرير طبعا القيمة الفعلية كما هي رقم لم تتغير وهي العمود الاول من الاستعلام الداخلي اللي هو مصدر مربع التحرير والاستعلام هذا هو صورة من جدول الصفحة / عمودين : ( رقم الصفحة / اسمها ) جعلنا مربع التحرير يعرض الاسم فقط لاننا جعلنا عرض عمود الرقم = صفر Data2.rar

السلام عليكم ورحمة الله وبركاته باختصار الموضوع أني استخدم كود لعرض قائمة مختصرة عند الضغط بزر الفأرة الأيمن داخل التقرير لعرض بعض المهام (كالطباعة وزوم) ودعت الحاجة الي التصدير الي الاكسل فكان الكود بهذا الشكل ولكن توقفت عند كيف أمرر اسم التقرير الحالي من القائمة المختصرة الي روتين التصدير الي اكسل وهذا الكود بالكامل للقائمة المختصرة Public Sub CreateShurtRepMenu() Dim cmbRightClick As Office.CommandBar Dim cmbControl As Office.CommandBarControl On Error Resume Next ' Create the shortcut menu. Set cmbRightClick = Application.CommandBars.Add("MyRepRightClkMenu", msoBarPopup, False, True) With cmbRightClick ' Add the fast Print command. ' Set cmbControl = .Controls.Add(msoControlButton, 2521, , , True) ' cmbControl.Caption = ChrW(1591) & ChrW(1576) & ChrW(1575) & ChrW(1593) & ChrW(1577) & ChrW(32) & ChrW(1587) & ChrW(1585) & ChrW(1610) & ChrW(1593) & ChrW(1577) ' ' Add the Print command. Set cmbControl = .Controls.Add(msoControlButton, 15948, , , True) cmbControl.Caption = ChrW(1578) & ChrW(1581) & ChrW(1583) & ChrW(1610) & ChrW(1583) & ChrW(32) & ChrW(1589) & ChrW(1601) & ChrW(1581) & ChrW(1575) & ChrW(1578) & ChrW(32) & ChrW(1575) & ChrW(1604) & ChrW(1591) & ChrW(1576) & ChrW(1575) & ChrW(1593) & ChrW(1577) ' Add the Excel command. '(msoControlButton, 11723, , , True) Set cmbControl = .Controls.Add 'add line for export group cmbControl.BeginGroup = True With cmbControl .Caption = "Excel" & " " & ChrW(1578) & ChrW(1589) & ChrW(1583) & ChrW(1610) & ChrW(1585) & ChrW(32) & ChrW(1573) & ChrW(1604) & ChrW(1610) .FaceId = 11723 .OnAction = "=ExportExcelSb(me.name)" End With ' Add the PDF or XPS command. Set cmbControl = .Controls.Add(msoControlButton, 12499, , , True) cmbControl.Caption = "PDF/XPS" & " " & ChrW(1578) & ChrW(1589) & ChrW(1583) & ChrW(1610) & ChrW(1585) & ChrW(32) & ChrW(1573) & ChrW(1604) & ChrW(1610) ' Add the Zoom command. Set cmbControl = .Controls.Add(4, 1733, , , True) cmbControl.BeginGroup = True cmbControl.Caption = "Zoom:" Cmdcontrol.FaceId = 202 ' Add the Close command. Set cmbControl = .Controls.Add(msoControlButton, 923, , , True) ' Start a new group. cmbControl.BeginGroup = True cmbControl.Caption = ChrW(1573) & ChrW(1594) & ChrW(1604) & ChrW(1575) & ChrW(1602) End With Set cmbControl = Nothing Set cmbRightClick = Nothing End Sub وهذا روتين التصدير الي الاكسل Public Sub ExportExcelSb(ByVal repname As String) Dim savPas As String savPas = calFilDilog(2, "Expor To Excel") DoCmd.OutputTo acOutputReport, repname, "Excel97-Excel2003Workbook(*.xls)", savPas, True, "", , acExportQualityPrint End Sub السؤال الآن كيف أمرر اسم التقرير الحالي هنا في هذا الكود الي الروتين الخاص بالتصدير. .OnAction = "=ExportExcelSb(me.name)" ملاحظة: أعلم أن هناك أمر مستقل داخل الـ commandbars للتصدير بدون الحاجة الي اجراء خاص ولكن هذا الأمر يظهر الفورم الخاص بأكسس لعملية تصدير التقرير ولا أريد اظهار هذه الشاشة. وجزاكم الله خيرا

السلام عليكم 🙂 الافضل ان يكون الاستعلام مصدر بيانات النماذج والتقارير ، ولا تأخذ الجداول كمصدر بيانات مباشر ، فهذا اللي عملته هنا : . ولا تعمل الكود على حدث "الخروج" من الحقل ، بينما الطريقة الصحيحة ان تضع الكود على حدث "بعد التحديث" : Private Sub tn_AfterUpdate() If DCount("*", "qry_tbl2", "HNO =" & Me.tn) = 0 Then MsgBox "الرقم غير موجود" Me.tn = "" Else Me.Recordset.FindFirst "hno=" & Me.tn End If End Sub . وجربت الكود الآخر ، فكان أبطأ من الذي ارفقته لك 🙂 جعفر 1335.انتقال.accdb.zip

يا اخي او ان تشرح بالتفصيل ما تريد او أعتذر انا عن المساعدة تساؤلات 1-عمل قائمة منسدلة في الخلية D3 تحتوى أسماء العملاء (في اي صفحة تريد ذلك؟؟؟؟) 2- عمل قائمة بأسماء الحسابات الموجودة في العمود A وتكون في العمود H (في اي صفحة تريد ذلك؟؟؟؟) 3-الخلية F3 في TextBox1 و وضع محتوى الخلية G3 في TextBox2 (لا أري اي TextBox أو 2TextBox في الملف ) 4- الملفي يجب ان يكون كما في المرفق ( و عندما يكتمل الملف لوّن ما تشاء و نسّق الالوان كما تريد) 5- كما ترى بعد ازالة النتسيقات انخفض حجم الملف من 255 كيلو الى 35 فقط ) حوالي 8 مرات Issa_Hatem.xlsm

وعليكم السلام 🙂 حتى لا يحدث لك هذا مرة ثانية: 1. تأكد بأن برنامج الاكسس فيه آخر التحديثات ، 2. هذا قد يكون بسبب بعض تحديثات مايكروسوفت للوندوز ، من موقع مايكروسوفت: Access reports that databases are in an 'inconsistent state' - Access (microsoft.com) - يكفي عمل هذا العمل على السيرفر (او الكمبيوتر الذي عليه نسخة الجداول) ، ولا يضر ان تعمله على كمبيوتر الواجهة وكمبيوتر الجداول : - افتح برنامج CMD كمسؤول ، Windows Start and then type Command. Right-click on Command Prompt and choose Run as administrator - ثم اكتب هذه الاسطر الثلاث (انسخ اول سطر من هنا ، والصقه هناك ، واضغط على زر Enter لتنفيذ الامر ، ثم الصق الثاني ونفذ الامر ، ثم الثالث ونفذ الامر) : REG ADD HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\lanmanserver\parameters /v DisableLeasing /t REG_DWORD /d 1 /f NET STOP SERVER NET START SERVER . والآن ، اعمل ضغط واصلاح لقاعدة البيانات ، وجربها في المحيط الجديد 🙂 جعفر

سبب بطء البرنامج هو كثرة الألوان والتنسيفات صورة عن صفحة واحدة من الملف تظهر ذلك ( جميع الصفحات بنفس النتيجة)

افتح نموذج البحث على التصميم وافتح الخصائص / لسان التبويب : حدث شوف الحدث : عند الفتح تجد مكتوب " اجراء حدث " تجد يسار الكلمة ثلاث نقاط صغيرة انقر على النقاط الثلاث سيأخذك الى محرر الفيجوال في حدث الفتح تجد السطر التالي : DoCmd.Maximize انسخه في الذاكرة اعمل في نماذجك الطريقة نفسها اي انك تفتح اي نموذج على التصميم ... الخ تختار حدث فتح وتختار اجراء حدث وتنقر على النقاط الثلاث ثم تلصق السطر المنسوخ ولا تنسى في خصائص كل فورم / لسان التبويب : غير ذلك عدل الخصيصة منبثق الى : نعم وبكذا اكون اشتركت معك في المخالفة ما قلنا نفتح لكل سؤال موضوع

يبدو أني تعجلت في كتابة الموضوع الحمد لله وجدت الحل بهذا الكود يمكن استدعاء اسم الكائن الحالي Application.CurrentObjectName وهذا أيضا يجلب اسم التقرير النشط Screen.ActiveReport.Name ولكن لا بأس لعل الفكرة يستفيد منها أحدا مر من هنا وجزاكم الله خيرا

اخي رعاك الله لا ادري ما تريد بالضبط لآن المرفق لا يوضح شيئا ولكني عملت لك شيئا حسب حدسي اليك التعديل انقر على زر البحث في النموذج الرئيسي ، سيفتح نموذج البحث ، اكتب رقم الفاتورة ثم انقر الزر انتر من لوحة المفاتيح اتمنى ان يحقق مطلوبك 13Data.rar

السلام عليكم و رحمة الله تعالى و بركاته بعد أن أنهينا الشطر الأول الخاص بالتعامل مع الويب من الأكسس بإستخدام أداة WebBrowser و هذا رابط الموضوع: نبدأ الآن بحول الله تعالى في الشطر الثاني و هو التعامل مع صفحات الويب بدون إستخدام أداة WebBrowser سوف نستخدم في هذا الموضوع طريقتين الأولى التعامل المباشر مع المتصفح Internet Explorer و الثانية بإستخدام سرفر معين الجزء الأول: التعامل المباشر مع المتصفح Internet Explorer في هذا الجزء إن شاء الله سوف نقوم بفتح نسخة من المتصفح Internet Explorer و نرسل لها بيانات أو نستقبل منها. سوف نستخدم مثال الأخ @ابوآمنة للتطبيق عليه بإرسال بيانات لنموذج غوغل من خلال متصفح خارجي: هذا هو الكود: Dim HTMLDoc As HTMLDocument Dim oBrowser As InternetExplorer Dim oHTML_Element As IHTMLElement Dim sURL As String On Error GoTo Err_Clear sURL = "https://docs.google.com/forms/d/e/1FAIpQLSejrVMF2ucvGdzXefD7MeoKze4_8Fn-ir7dHmrAIwduHzBbtg/viewform" Set oBrowser = New InternetExplorer oBrowser.Silent = True oBrowser.Navigate sURL oBrowser.Visible = False Do ' Wait till the Browser is loaded Loop Until oBrowser.ReadyState = READYSTATE_COMPLETE Set HTMLDoc = oBrowser.Document HTMLDoc.getElementsByTagName("input").Item(0).Value = Me.n1 HTMLDoc.getElementsByTagName("input").Item(1).Value = Me.n2 HTMLDoc.getElementsByClassName("appsMaterialWizButtonPaperbuttonLabel quantumWizButtonPaperbuttonLabel exportLabel").Item(0).Click Do ' Wait till the Browser is loaded Loop Until oBrowser.LocationURL <> sURL oBrowser.Quit MsgBox "لقد تم إرسال البيانات بنجاح" Me.n1 = "" Me.n2 = "" Err_Clear: If Err <> 0 Then Err.Clear Resume Next End If شرح الكود: Dim HTMLDoc As HTMLDocument Dim oBrowser As InternetExplorer Dim oHTML_Element As IHTMLElement Dim sURL As String هنا قمنا بتعريف المتغيرات التي نحتاجها sURL = "https://docs.google.com/forms/d/e/1FAIpQLSejrVMF2ucvGdzXefD7MeoKze4_8Fn-ir7dHmrAIwduHzBbtg/viewform" هذا رابط الموقع Set oBrowser = New InternetExplorer إسناد نسخة من جديدة من Internet Explorer للمتغير oBrowser oBrowser.Silent = True oBrowser.Navigate sURL oBrowser.Visible = False السطر الأول هو إيقاف ظهور رسائل الأخطاء من المتصفح السطر الثاني تصفح الرابط sURL السطر الثالث التحكم في إظهاء أو إخفاء المتصفح أثناء العمل عليه Do ' Wait till the Browser is loaded Loop Until oBrowser.ReadyState = READYSTATE_COMPLETE الإنتظار إلى حين تحميل الصفحة HTMLDoc.getElementsByTagName("input").Item(0).Value = Me.n1 HTMLDoc.getElementsByTagName("input").Item(1).Value = Me.n2 إرسال قيم للمربع الأول و الثاني HTMLDoc.getElementsByClassName("appsMaterialWizButtonPaperbuttonLabel quantumWizButtonPaperbuttonLabel exportLabel").Item(0).Click الضغط على زر إرسال Do ' Wait till the Browser is loaded Loop Until oBrowser.LocationURL <> sURL إجراء حلقة دورانية لا يخرج منها إلا عند تغير رابط الصفحة و ذلك عند الضغط على زر الإرسال oBrowser.Quit إغلاق المتصفح بعد إرسال البيانات للتجربة افتح المرفق و ادخل بيانات في المربع الأول و المربع الثاني و اضغط على زر الإرسال و لاحظ ماذا يحدث و للإطلاع على ظهور النتائج ادخل على هذا الرابط: https://docs.google.com/spreadsheets/d/e/2PACX-1vSi73gAAIE9Rv8Ux43jjcvq9SSpzdVzs3M3ZEtehWqqP0pW4NLFLnkX3Iqoc9dYm_cx8vPz9S1465zd/pubhtml ارسال بيانات لنماذج غوغل.rar

جرب هذا الكود (لا تنس اضافة صف فارغ تماماً في كل صفحة الصف رقم 6 /مخفي لعدم الكتابة فيه عن طريق الخطأ) Option Explicit Sub taj() Dim P As Worksheet Dim D As Worksheet Dim m%, i%, Rod, Rop% Dim Obj As Object Set D = Sheets("DATA") Set P = Sheets("print") Set Obj = CreateObject("System.Collections.ArrayList") Rod = D.Cells(Rows.Count, 1).End(3).Row Rop = P.Cells(Rows.Count, 1).End(3).Row If Rod < 7 Then Exit Sub D.Cells(7, "H").Resize(Rod).ClearContents With Obj For i = 7 To Rod If Not .contains(D.Cells(i, 1).Value) And _ D.Cells(i, 1) <> vbNullString Then .Add D.Cells(i, 1).Value End If Next i .Sort D.Cells(7, "H").Resize(.Count) = _ Application.Transpose(.ToArray) End With With D.Cells(3, "D").Validation .Delete .Add 3, Formula1:=Join(Obj.ToArray, ",") End With With P.Cells(3, "B").Validation .Delete .Add 3, Formula1:=Join(Obj.ToArray, ",") End With Set Obj = Nothing End Sub الملف مرفق Issa_Macro.xlsm

الشكر لله ثم لاخواننا واساتذتنا جزاهم الله خيرا هذا الكود موضوع فى وحده نمطيه وتم استدعائها فى الاستعلام كالتالى Expr2: Horizontal("[اذونات التوريد]";"[اسم الموظف]";"[اكتشاف مخالفات]";[اسم الموظف]) بالتوفيق

السلام عليكم هل فعلت خاصية الضغط والإصلاح عند الإغلاق؟

تم التعديل كما تريد 1-تحنار الفضل من الخلية Bx6 ثم تضغط على الزر Fasl 2- الماكرو القديم ما زال يعمل (للفصلين معاً ) الزر ALL الماكرو الجديد Option Explicit Sub checK_up_By_Fasl() Dim F As Worksheet Dim Arr(), Itm, My_sum Dim m%, K%, i%, Ro%, y% Dim arr_madda() Const a = 4 Const b = 1 Dim Nb% Dim Res(), XX%, MY_text$ Dim Txt$: Txt = "المجمــــــوع الكلـــــــي" Set F = Sheets("F1") Ro = F.Cells(Rows.Count, 3).End(3).Row If Ro < 12 Then Exit Sub F.Cells(12, "H").Resize(Ro - 11, 49).Interior.ColorIndex = xlNone F.Cells(12, "Ca").Resize(Ro - 11, 49).ClearContents F.Cells(12, "Bx").Resize(Ro - 11).ClearContents Select Case F.Range("Bx6") Case "الأول": Nb = a Case "الثاني": Nb = b End Select For K = 8 To 55 If F.Cells(7, K) = Txt Then ReDim Preserve Arr(m): Arr(m) = K - Nb: m = m + 1 End If Next m = 0 For K = 8 To 50 If F.Cells(6, K) <> "" Then ReDim Preserve arr_madda(m) arr_madda(m) = F.Cells(6, K) & " / " & F.Range("Bx6") m = m + 1 End If Next For i = 12 To Ro y = 0 For Each Itm In Arr My_sum = My_sum + F.Cells(i, Itm) If F.Cells(i, Itm) < F.Cells(10, Itm) / 2 Then F.Cells(i, Itm).Interior.ColorIndex = 6 ReDim Preserve Res(y) Select Case Itm Case Is <= 13: Res(y) = arr_madda(0) Case Is <= 20: Res(y) = arr_madda(1) Case Is <= 27: Res(y) = arr_madda(2) Case Is <= 34: Res(y) = arr_madda(3) Case Is <= 41: Res(y) = arr_madda(4) Case Is <= 48: Res(y) = arr_madda(5) Case Is <= 55: Res(y) = arr_madda(6) End Select y = y + 1 End If Next Itm If y > 1 Then F.Cells(i, "Ca").Resize(, y) = Res Else F.Cells(i, "Bx") = My_sum End If Erase Res: y = 0: My_sum = 0 Next i End Sub الملف من جديد Khiri_ali_New.xlsm

سلسلة تعليم بور كويري الجزء الرابع عشر كيفية دمج اعمدة باكثر من طريقة في البور كويري how to MergingColumns in power query في الفيديو دة تقدر تدمج اعمدة مع بعض باكثر من طريقة

مشاركه مع اخى واستاذى @kanory جزاه الله خيرا تم اضافه وحده نمطيه تعلمتها من اسخى @kanory جزاه الله خيرا ان شاء الله يكون ما تريد Public Function Horizontal(tabelle As String, Feld1 As String, Feld2 As String, valFeld1) Dim DB As dao.Database, rs As dao.Recordset Set DB = CurrentDb Set rs = DB.OpenRecordset("select distinct " & Feld2 & " from " & tabelle _ & " where " & Feld1 & "='" & valFeld1 & "' order by " & Feld2) Do If rs.AbsolutePosition = rs.BOF Then Horizontal = rs(Feld2) Else Horizontal = Horizontal & ", " & rs(Feld2) End If rs.MoveNext Loop Until rs.EOF rs.Close DB.Close Set rs = Nothing Set DB = Nothing End Function بالتوفيق الدمج عند الاستعلام.accdb

أبشر ان شاء الله ولكن أقوم بمعالجة شئ ما وعند الفراغ منه سأرفق لك مرفق ان شاء الله

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

اضافة الي ما تفضل به استاذنا جعفر استخدم هذا المرفق سيساعدك ان شاء الله في عدم ادخال اللغة العربية في محرر الأكواد ملاحظة هامة: المرفق للأستاذ أبو جودي جزاه الله خيرا ويمكنك استخدام نفس الفكرة بالنسبة للغة الفرنسية أو أي لغة أخري غير الانكليزية Converter Arabic and Unicode.mdb

السلام عليكم لم أفهم بالضبط ما تريده... وهذه محاولة الرد على مشاركتك الأخيرة.... My_if.xlsx

انت وضعت 7 أعمدة لمواد الرسوب من العامود 79 الى العامود 85 (ممكن ان بكون عدد هذه المواد اكثر) لذلك وضعت انا اعمدة زيادة (خاصة انه لكل مادة اكثر من فصل واحد) اما ترتيب المواد ذلك يكون حسب ورودها في الجدول (اذا كانت اول مادة رسوب للطالب (فلان) هي الرياضيات مثلاً فانك تجدها الأولى في الجدول (في الصف) الذي يخصه النسبة لم اتدخل بها لانها مجرد معادلة بسيطة

انا قلت لا تكتب غير الانجليزية في الكود ، ويمكنك ، ان تستعمل جميع اللغات في البرنامج ، كما في المثال في الرابط الذي ارفقته لك في مشاركتي السابقة 🙂 جعفر

أزnssj جرب هذا لعله يظبط انتقال.accdb

أ.nssj جرب المرفق عسي يكون المطلوب ادخل الرقم المراد البحث عنه واضغط انتر بالتوفيق انتقال.accdb

جرب هذا الماكرو Option Explicit Sub checK_up() Dim F As Worksheet Dim Arr(), Itm, My_sum Dim m%, K%, i%, Ro%, y% Dim arr_madda() Dim Res(), XX%, MY_text$ Dim Txt$: Txt = "المجمــــــــــوع" Set F = Sheets("F1") Ro = F.Cells(Rows.Count, 3).End(3).Row If Ro < 12 Then Exit Sub F.Cells(12, "H").Resize(Ro - 11, 49).Interior.ColorIndex = xlNone F.Cells(12, "Ca").Resize(Ro - 11, 49).ClearContents F.Cells(12, "Bx").Resize(Ro - 11).ClearContents For K = 8 To 55: If F.Cells(9, K) = Txt Then ReDim Preserve Arr(m): Arr(m) = K: m = m + 1 End If Next m = 0 For K = 8 To 50 If F.Cells(6, K) <> "" Then ReDim Preserve arr_madda(m): arr_madda(m) = F.Cells(6, K) m = m + 1 End If Next For i = 12 To Ro y = 0 For Each Itm In Arr My_sum = My_sum + F.Cells(i, Itm) If F.Cells(i, Itm) < F.Cells(10, Itm) / 2 Then F.Cells(i, Itm).Interior.ColorIndex = 6 ReDim Preserve Res(y) Select Case Itm Case Is <= 13: Res(y) = arr_madda(0) Case Is <= 20: Res(y) = arr_madda(1) Case Is <= 27: Res(y) = arr_madda(2) Case Is <= 34: Res(y) = arr_madda(3) Case Is <= 41: Res(y) = arr_madda(4) Case Is <= 48: Res(y) = arr_madda(5) Case Is <= 55: Res(y) = arr_madda(6) End Select y = y + 1 End If Next Itm If y > 1 Then F.Cells(i, "Ca").Resize(, y) = Res Else F.Cells(i, "Bx") = My_sum End If Erase Res: y = 0: My_sum = 0 Next i End Sub الملف مرفق Khiri_ali.xlsm

اخي الكريم بامكانك عمل مصادقة عن طريق اسم المستخدم والرقم السري المشار اليه أعلاه Amr - **** بالاضافة الى عنوان الـ uuid الخاص بجهاز المستخدم الذي يحاول الدخول .. بمعنى اخر عندما يقوم احد المستخدمين بتسجيل الدخول باسم Amr والرقم السري **** يقوم نموذج تسجيل الدخول بقراءة رقم الـ uuid لجهاز المستخدم هذا ومن ثم يخزن هذا الرقم في الجدول الذي فيه بيانات الدخول username password uuid وعندما يقوم مستخدم اخر بادخال نفس الاسم والرقم من جهاز اخر يقوم نموذج الدخول بالتحقق من وجود رقم ال uuid اذا ما كان موجود بالجدول ام لا .. فلو وجد ان الرقم مسجل في الجدول عندها يخبر المستخدم بان هذا الاسم مفتوح على جهاز اخر واذا لم يجد رقم مخزن في حقل ال uuid يقوم النموذج بتخزين رقم ال uuid للمستخدم الجديد طبعا لابد من وضع كود يحذف رقم ال uuid من الجدول عندما يقوم المستخدم الاول بتسجيل خروجه لكي يسمح لمستخدم اخر بالدخول ملاحظة: رقم الـ uuid هو رقم فريد لكل جهاز كومبيوتر لايتكرر ولا يتغير حتى لو تمت فرمته الجهاز وهنالك كود يعمل على قراءة هذا الرقم Public Function GetUUID() On Error Resume Next Dim strComputer As String Dim objWMIService, colItems, objItem strComputer = "." 'default to localhost Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2") Set colItems = objWMIService.ExecQuery("Select * from Win32_ComputerSystemProduct", , 48) For Each objItem In colItems GetUUID = Nz(Trim(objItem.UUID), 0) Next End Function اتمنى ان تكون الفكرة واضحة تحياتي

المطلوب وهو لا شك الأفضل لك ان توزع طلباتك هذه على اربع مشاركات جديدة ولك الخيار بان ترفعها جملة واحدة كل سؤال بموضوع مستقل او ان ترفعها متتابعة بمعنى : حين تحصل على اجابة سؤال ترفع الآخر اعانك الله ووفقك ،،،

شكرا جزيلا اخي الكريم لقد نفذ ما اقصد بالضبط ♥️♥️♥️♥️🙏 شكرا لجهودك وأكرمك الله فيما تعمل

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

لا يُنصح بالكتابة في الكود VBE إلا باللغة الانجليزية ، وخصوصا وبرنامجك ظاهرا عليه انه متعدد اللغات ، وهذا الرابط سيفيدك : اعمل برنامجك بعدة لغات وببساطة - قسم الأكسيس Access - أوفيسنا (officena.net) جعفر

تفضل بعد اذن جميع الأساتذة الملف1.xlsx

اخي ازهر بصراحة ما فهمت طلبك لكن جرب هذا و عدل حسب حاجتك Dim db As DAO.Database Dim rs As DAO.Recordset Set db = CurrentDb Set rs = db.OpenRecordset("SELECT * FROM [HUR] WHERE [ID]=[Forms]![fur]![ID];") If Not rs.BOF And Not rs.EOF Then rs.MoveFirst While (Not rs.EOF) [ur] = rs.Fields("ID") Wend End If rs.Close Set rs = Nothing

أكثر اختصاراً Sub test() Dim a As Variant Dim i As Long Dim sh1 As Worksheet: Dim sh2 As Worksheet: Dim sh3 As Worksheet Set sh1 = Sheets("sheet1"): Set sh2 = Sheets("sheet2"): Set sh3 = Sheets("sheet3") a = Split(Join(Application.Transpose(sh2.Range("b3:b" & sh2.Cells(Rows.Count, 2).End(xlUp).Row)), "#") _ & "#" & Join(Application.Transpose(sh3.Range("b3:b" & sh3.Cells(Rows.Count, 2).End(xlUp).Row)), "#"), "#") With CreateObject("scripting.dictionary") For i = 0 To UBound(a) If a(i) <> "" Then If Not .exists(a(i)) Then .Add a(i), .Count + 1 End If End If Next sh1.Range(sh1.Range("a3"), sh1.Range("a3").End(xlDown)).Resize(, 2).ClearContents sh1.Range("a3").Resize(.Count, 2) = Application.Transpose(Array(.items, .keys)) End With End Sub جلب الاسماء من عدة شيتات مع عدم التكرار.xlsm

جرب هذا الماكرو ( لا صفوف فارغة في الجداول لان الماكرو يتوقف عند أول حلية فارغة) Option Explicit Sub All_in_One() Dim First As Worksheet Dim arr(1), Sh, i% Dim dic As Object Set First = Sheets("Sheet1") Set dic = CreateObject("Scripting.Dictionary") arr(0) = "Sheet2": arr(1) = "Sheet3" First.Range("B1").CurrentRegion.ClearContents For Each Sh In arr i = 3 Do Until Sheets(Sh).Range("B" & i) = vbNullString dic(Sheets(Sh).Range("B" & i).Value) = vbNullString i = i + 1 Loop Next Sh If dic.Count Then First.Range("B2") = "Names" First.Range("B3").Resize(dic.Count) = _ Application.Transpose(dic.keys) First.Range("A3").Resize(dic.Count) = _ Evaluate("Row(1:" & dic.Count & ")") End If Set dic = Nothing: Set First = Nothing Erase arr End Sub الملف مرفق Muneef.xlsm

أولاً لا ضرورة لهذه التنسيفات والزركشة يالألوان المبهرة التي تجعل الملف ثقيلاً ثانياً ما الحاجة التي دمج الخلايا التي تعيق عمل الكود ثالثأً العمل بجب ان يكون كما في المرفق ( اضغط الزر OK ) و تنتقل البيانات الى الشيت Data مع حبار التبديل اذا كان الشحص مسجلاً Option Explicit Sub Get_date_and_time() Dim M As Worksheet, D As Worksheet Dim Rg_M As Range, Rg_D As Range Dim find_me As Range Dim Ro%, Answer As Byte Set M = Sheets("Main"): Set D = Sheets("Data") Set Rg_M = M.Range("D3:D7") Set Rg_D = D.Range("B1:B34") Set find_me = Rg_D.Find(Rg_M.Cells(2), lookat:=1) If find_me Is Nothing Then MsgBox "This Name " & Rg_M.Cells(2, 2) & "Not Exist" Exit Sub Else Ro = find_me.Row If Rg_D.Cells(Ro).Offset(, 1) <> "" Then Answer = MsgBox("This person " & """" & _ Rg_M.Cells(2, 2) & """" & " is registered" & Chr(10) & _ "Do you want to change", vbYesNo) If Answer = 6 Then D.Cells(Ro, 3) = Format(M.Cells(6, 4), "dd-mm-yyy") D.Cells(Ro, 4) = Format(M.Cells(7, 4), "hh : mm") Exit Sub End If End If D.Cells(Ro, 3) = Format(M.Cells(6, 4), "dd-mm-yyy") D.Cells(Ro, 4) = Format(M.Cells(6, 4), "hh : mm") End If End Sub Shalapy.xlsm

كبف تقوم باستعمال دالة مرتبطة بشيت غير موجود (عبدالرحمن الغرابلي)

الحمد لله

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

وعليكم السلام -اهلا بكم فى المنتدى طالما انكى لم تقومى برفع ملف وشرح عليه المطلوب بشكل دقيق فيمكنك رؤية هذا الرابط داخل المنتدى فبه ملف سوف يفيدك https://www.officena.net/ib/topic/70419-برنامج-جرد-العهده-المخزنيه/ ولدى برنامج اخر بالأكسيس -تفضلى ادارة عهد المستودع.accdb