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

هذه المحاولة (الملف مرفق) zahra_Final_2.xlsm

تم النعديل كما تريدين Option Explicit Sub show_all() show_Columns show_rows End Sub '+++++++++++++++++++++++++++++++ Sub Hid_col() show_Columns show_rows Dim rg As Range, y% Set rg = Selection If rg.Columns.Count > 1 Then Set rg = rg.Cells(1, 1) End If y = rg.Column If y > 7 Then Exit Sub With Sheets("Sheet1").Range("A1:G1") .Columns.Hidden = True .Columns(y).Hidden = False .Columns(1).Hidden = False Application.Goto .Cells(1, 1) End With Hide_row (y) End Sub '+++++++++++++++++++++++++++++++++ Sub show_Columns() Sheets("sheet1").Columns.Hidden = False End Sub '+++++++++++++++++++++++++++++++++++ Sub show_rows() Sheets("sheet1").Rows.Hidden = False End Sub '++++++++++++++++++++++++++++ Sub Hide_row(ByVal x) Dim t%, m% With Sheets("sheet1") t = .Cells(Rows.Count, x).End(3).Row For m = 3 To t Step 2 If .Cells(m, x) = 0 Or _ .Cells(m, x) = vbNullString Then .Cells(m, x).EntireRow.Hidden = True End If Next End With End Sub الملف من جديد zahra_Final.xlsm

أولاً يجب عليك ان تذكر من وضع لك الكود في المشاركة التي رفعتها الكود '+++++++++++++++++++++++++++++++++++ Sub show_Col() Sheets("sheet1").Columns.Hidden = False End Sub '+++++++++++++++++++++++++++++++++++ Sub show_all() Sheets("sheet1").Rows.Hidden = False End Sub '++++++++++++++++++++++++++++ Sub hid_rows_and_columns() HideRows Hid_col End Sub Sub Show_rows_and_columns() show_Col show_all End Sub '+++++++++++++++++++++++++++++++++++ Sub HideRows() Dim Ro%, i% With Sheets("Sheet1") .Rows.Hidden = False Ro = .Cells(Rows.Count, "C").End(3).Row For i = 1 To Ro If .Cells(i, 1) = vbNullString And _ Application.Sum(.Cells(i, "d").Resize(, 7)) = 0 Then .Cells(i, 1).EntireRow.Hidden = True End If Next End With End Sub ''+++++++++++++++++++++++++++++++++++ Sub Hid_col() Dim rg As Range, y% Set rg = Selection If rg.Columns.Count > 1 Then Set rg = rg.Cells(1, 1) End If y = rg.Column If y > 7 Then Exit Sub With Sheets("Sheet1").Range("A1:G1") .Columns.Hidden = True .Columns(y).Hidden = False Application.Goto .Cells(1, y) End With End Sub الملف مرفق zahra_M.xlsm

السلام عليكم 🙂 انا عملت تغيير في النموذج ، واصبح بسيط : . بس هذه طريقة المجلدات . كود النموذج الرئيسي: Option Compare Database Option Explicit Private Sub cmd_quit_Click() DoCmd.Close acForm, Me.Name End Sub Private Sub Form_Load() Dim rst As DAO.Recordset Dim Pics_Path As String Dim RC As Long, i As Long 'the main buttons Set rst = CurrentDb.OpenRecordset("Select [FN],[Resturant] From Query_S_S Where S_S is not null Order By S_S") rst.MoveLast: rst.MoveFirst: RC = rst.RecordCount For i = 1 To 6 'path to the pitures folder Pics_Path = Mid(Application.CurrentProject.Path, 1, InStrRev(Application.CurrentProject.Path, "\") - 1) Me("cmd" & i).Caption = rst!Resturant Me("cmd" & i).Picture = Pics_Path & "\my foto333\" & rst!FN rst.MoveNext Next i rst.Close: Set rst = Nothing 'show if 1st button clicked Me.WhichCMD = 1 Call sfrm_Controls End Sub Function cmd_Click() Me.WhichCMD = Right(Screen.ActiveControl.Name, 1) Call sfrm_Controls End Function Function sfrm_Controls() On Error GoTo err_sfrm_Controls Dim rst As DAO.Recordset Dim Pics_Path As String Dim RC As Long, i As Long, iStart As Long Dim ctl As Control 'the main buttons Set rst = CurrentDb.OpenRecordset("Select [FN],[ID], [iName] From qry_Table1 Where S_S=" & Me.WhichCMD & " Order By ID") rst.MoveLast: rst.MoveFirst: RC = rst.RecordCount For i = 1 To RC 'path to the pitures folder, then path with file name Pics_Path = Mid(Application.CurrentProject.Path, 1, InStrRev(Application.CurrentProject.Path, "\") - 1) Pics_Path = Pics_Path & "\my foto333\" & rst!FN Me("sfrm_items")("c" & i).BackColor = Me("cmd" & WhichCMD).BackColor 'Back Color Me("sfrm_items")("c" & i).ForeColor = Me("cmd" & WhichCMD).ForeColor 'Fore Color Me("sfrm_items")("c" & i).Caption = rst!INAME 'Caption 'picture If Dir(Pics_Path) <> "" Then Me("sfrm_items")("c" & i).Picture = Pics_Path Else 'file type was not found, trye jpg Me("sfrm_items")("c" & i).Picture = Mid(Pics_Path, 1, Len(Pics_Path) - 3) & "jpg" End If Me("sfrm_items")("c" & i).Tag = rst!ID 'ID in Tag , so when clicking on the button we know which one Me("sfrm_items")("c" & i).Visible = True 'show the control rst.MoveNext Next i 'hide all subform controls For Each ctl In Me("sfrm_items").Controls Me("sfrm_items")("c" & i).Visible = False i = i + 1 Next Exit_sfrm_Controls: rst.Close: Set rst = Nothing Exit Function err_sfrm_Controls: If Err.Number = 2220 Then 'No picture Me("sfrm_items")("c" & i).Picture = "" Resume Next ElseIf Err.Number = 2465 Then 'we passed the number of controls Resume Exit_sfrm_Controls Else MsgBox Err.Number & vbCrLf & Err.Description End If End Function . ولما تنقر على اي من ازرار النموذج الفرعي ، تحصل على . وكود النموذج الفرعي: Option Compare Database Option Explicit Function myItems() 'get the items detail Dim A As String Dim x() As String Dim Resturant As String, S_S As Double, INAME As String, sal_price As Double, Qty1 As Integer, ID As Long A = DLookup("Resturant & '|' & S_S & '|' & INAME & '|' & sal_price & '|' & Qty1", "TABL1", "[ID]=" & Screen.ActiveControl.Tag) x = Split(A, "|") Resturant = x(0) S_S = x(1) INAME = x(2) sal_price = x(3) Qty1 = x(4) ID = Screen.ActiveControl.Tag MsgBox "Resturant =" & x(0) & vbCrLf & _ "S_S =" & x(1) & vbCrLf & _ "INAME =" & x(2) & vbCrLf & _ "sal_price =" & x(3) & vbCrLf & _ "Qty1 =" & x(4) & vbCrLf & _ "[ID]=" & Screen.ActiveControl.Tag End Function جعفر 1321.1.RestTest111.accdb.zip

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

السلام عليكم ورحمة الله وبركاته كيف الحال؟ يا رب دايما بخير وسعادة ورضى بالمكتوب ومحاولات جاهدة لنكون أفضل مما كنا عليه حياكم الله وبعد اليوم أحببت أن أشارك أحبابي في الله مشرفي وأعضاء وزوار موقعنا الغالي على قلوبنا جميعا ملتقى الأوفيس العربي الأول على مستوى الانترنت أوفيسنا بمعلومة مفيدة جدا لكل من يريد التطبيق العملي للتعليمات الموجودة في فيديوهات الشروح ومن يريد الاستمتاع بمشاهدة يوتويب أثناء تصفحه باقي المواقع إليكم الطريقة بمنتهى البساطة ملحوظة: العمل على متصفح جوجل كروم وذلك من خلال إضافة تسمى floating for YouTube extension وولا ينقصني سوى دعاؤكم لي بالخير في الدنيا والآخرى وإن أعجبكم الفيديو استفدتم به فلا تبخل على غيرك بمشاركته معهم فلو بخل به غيرك ما وصل إليك والآن مع الفيديو وفقنا الله وإياكم لكل ما يحب ويرضى وتسعدني تعليقاتكم ولو بكلمة انتظرونا فالقادم أفضل

ليأجرك الله بمصابك - ولا تحزن فلعله خير يدخره الله لك دائما يكون لدي الواحد منا نسخة بل نسخ مختلفة هنا وهنا للمشروع الواحد لعلك أخذت نسخة للعمل أو نسخة أخري بالمنزل وكذلك نسخة علي فلاش مومري لتتنقل بها الي مكان آخر فتش عن أحد هذه النسخ لعلك تسترجع ما يمكنك ارجاعه قد مررت بتجربة مثل هذه وتم حذف جميع الأكواد من البرنامج من الفورم والموديل وكل شئ - من جهاز العمل - ولكن هذه التجربة علمتني ان لا أترك محرر أكود الـ vba بدون حماية وكذلك قاعدة بيانات الجداول الخلفية - وأن احتفظ بنسخة احتياطية كل فترة زمنية (ويستحسن أن تكون قريبة) من البرنامج بشقيه الأمامي والخلفي. وبفضل الله أنقذتني نسخة قديمة كانت بجهاز المنزل. قد احتاجت بعض التعديلات اليسيرة ولكن الأمور مرت بسلام والحمد لله. حاول أن تكون تلك تجربة تتعلم منها ولا تبتأس فان فرج الله قريب.

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

حياك الله 🙂 في تعديل بسيط ، حيث تم اضافة مربع النص NoFocus في النموذج الفرعي ، ويجب ان لا تجعله مخفي ، ويمكنك ان تجعله تحت اول زر امر اذا اردت ، السبب في احتياجه هو ، عندما نختار مادة وتظهر لنا رسالة بياناتها (طبعا انت لن تستعمل الرسالة ، وانما ستستخدم بياناتها 🙂) ، فلا تستطيع ان تختار من القائمة الرئيسية مرة اخرى : . واما في الكود ، فقد تم اضافته في كود النموذج الفرعي ، هكذا: . جعفر 1321.1.RestTest111.accdb.zip

هذا التعديل (تم التجربة على العامود B ) وكانت النتيجة كما تريدين 1- جدول المقارنة (قبل الماكرو وبعده ) الذي ارسلته (في النطاق L1 الى M25 ) كما تلاحظين بعد تنفيذ الماكرو (على العامود B) كل الكلمات "إخفاء " يتم اخفاء صفوفها الملف مرفق zahra_Final_1.xlsm

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

يجب تحديد خلية داخل الجدول قبل تنفيذ الكود لأنه اذا كانت الخلية المحددة خارج الجدول الماكرو يتحاهلها

استبدال ما موجود في المربع الأحمر بما هو في المربع الأزرق

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

أضف الى الكود هذا السطر (الصورة)

شاهد هذا الموضوع لعله يفيدك

ضع هذا الكود تحت حدث الزر If DLookup("nam", "nam", "[nam] = '" & Me.tt & "'") = Me.tt Then MsgBox "هذا الاسم موجود مسبقا" 'DoCmd.Close End If

وجدت في ارشيفي برنامج للمخازن و المستودعات اسأل الله لمن صممه التوفيق و السداد .. برنامج مستودعات.rar

بارك الله فيك وجزاك الله خيرا

استعمل هذه المعادلة بدل التي وضعتها لتفادي الخطأ في حال تم كتابة نص او اي شيء غير الارقام في العامودين I و J الملف مرفق من جديد marwa_New_2.xlsm

اعرض الملف البرنامج الطبي الشامل برنامج للمراكز الطبيه يشمل الاستعلامات والمختبر وقسم الحسابات واقسام اخرى صاحب الملف الدكتور جمال راجح تمت الاضافه 24 مار, 2019 الاقسام قسم الأكسيس

اخي هاني الافضل هو العمل على الاستعلام بدل الكود ، لذا ، رجاء اعطنا الاستعلام او الكود او صورة من الخطأ ، او اي معلومة ممكن تساعدنا علشان نساعدك 🙂 جعفر

وعليكم السلام-تفضل أسماء جميع العاملين بالمدرسة.xlsm

تفضل أخي الكريم بالطريقتين نسبه مئويه.xlsm نسبه مئويه.xlsx

تمت الاجابة على هذا السؤال في مشاركة سابقة لا حاجة للماكرو يكفي ان تغير قيمة الخلية B1 لتحصل على النتيجة (مع انك ارسلت جدول فراغ و قد قمت بتعبئته ببيانات عشوائية بدل فيها ما تراه متاسباً) Adnan mushtaha.xlsx

اذا كنت قد فهمت عليك ما تريده لا حاجة للكود Adnan mushtaha.xlsx

هذه يحتاج لها شرح لوسمحت ، وبالتفصيل 🙂 جعفر

بعد اذن الاخ حسين لا حاجة للحلقات التكرارية التي ترهق البرنامج (في حال البيانات الكثيرة أكثر من 500 صف) في حين يمكن وضع اليد مباشرة على الخلية المطلوبة بواسطة الدالّة Find Option Explicit Sub find_me() Dim ws1 As Worksheet Dim ws2 As Worksheet Dim RG1 As Range Set ws1 = Sheets("ورقة1") Set ws2 = Sheets("ورقة2") ws2.Cells(7, 2).Resize(4).ClearContents Set RG1 = ws1.Range("A1").CurrentRegion.Columns(2). _ Find(ws2.Range("C3"), Lookat:=1) If Not RG1 Is Nothing Then ws1.Cells(RG1.Row, 1).Resize(, 4).Copy ws2.Cells(7, 2).PasteSpecial (12), Transpose:=True End If Application.CutCopyMode = False ws2.Cells(3, 3).Select End Sub كما يمكن عمل ذلك بمعادلة بسيطة =OFFSET(INDEX(ورقة1!$B$2:$B$9,MATCH($C$3,ورقة1!$B$2:$B$9,0)),,ROWS($A$1:A1)-2) الملف مرفق Adnan.xlsm

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

sum(round(total ; 2)) شكرا لك اخي الكريم على حرصك على نفع اخوانك وعرض ما توصلت اليه وهذه الدالة مألوفة للجميع وتستخدم كثيرا ، ولكن قد تغيب عن البال ، لاعتماد الغالبية على التطبيق العملي لحل المشكلات البرمجية ----------------------------------------------------------------------------------- وحسب علمي ان دالة round في الكود اعلاه تسبق دالة sum ليصبح الترتيب هكذا round(sum(total);2) ما رأي خبرائنا في ذلك ؟

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

اخواني الكرام اضع بين ايديكم الجزء الاول من شرح الترحيل وبإنتظار تعليقاتكم واستفسارتكم ابواحمد الجزء الاول من الشرح ملف شرح الجزء الاول الترحيل.rar الجزء الثاني من الشرح ملف شرح الجزء الثانى الترحيل2.rar الجزء الثالث من الشرح (ترحيل القيم - ترحيل محدوود) ملف شرح الجزء الثالث الترحيل3.rar الجزء الرابع من شروحات الترحيل ملف شرح الجزء الرابع ترحيل حسب اسم الشيت.rar لا تنسوني أخوتي من الدعاء لي بظهر الغيب

وعليكم السلام هذه 6 طرق ، برسائل وبدون ، وانا اخترت لك آخر واحدة منها ، وهي تعطيك شريط في اسفل شاشة الاكسس: . Option Compare Database Private Sub أمر10_Click() On Error GoTo Err_أمر10_Click 'Dim stDocName As String 'stDocName = "q1" 'DoCmd.OpenQuery stDocName, acNormal, acEdit '1 العمل بصمت وبدون اشعارات ' CurrentDb.Execute ("q1") '2 العمل بصمت وبدون اشعارات ' DoCmd.SetWarnings False ' DoCmd.OpenQuery "q1" ' DoCmd.SetWarnings True '3 العمل بصمت وبدون اشعارات ، ولكن بوجود ساعة ترابية تشير الى وجود عمل ' DoCmd.Hourglass True ' DoCmd.OpenQuery "q1" ' DoCmd.Hourglass False '4 عمل اشعار ثابت لمدة 3 ثوان في اسفل الشاشة ' Application.SetOption "Show Status Bar", True ' Application.Echo True ' Application.Echo False, "الاستعلام يقوم بالتحديث" ' ' DoCmd.SetWarnings False ' DoCmd.OpenQuery "q1" ' DoCmd.SetWarnings True ' ' PauseTime = 3: Start = Timer ' Do While Timer < Start + PauseTime ' DoEvents ' Loop ' ' Application.SetOption "Show Status Bar", False ' Application.Echo True '5 عمل اشعار متغير لمدة 3 ثوان في اسفل الشاشة ' Application.SetOption "Show Status Bar", True ' SysCmd acSysCmdSetStatus, "الاستعلام يقوم بالتحديث" ' DoCmd.SetWarnings False ' DoCmd.OpenQuery "q1" ' DoCmd.SetWarnings True ' ' PauseTime = 3: Start = Timer ' Do While Timer < Start + PauseTime ' DoEvents ' A = A + 1 ' If A / 50 = Int(A / 50) Then B = B & " . " ' SysCmd acSysCmdSetStatus, B & "الاستعلام يقوم بالتحديث" ' Loop ' Application.SetOption "Show Status Bar", False ' SysCmd acSysCmdClearStatus '6 عمل اشعار متغير لمدة 3 ثوان في اسفل الشاشة Application.SetOption "Show Status Bar", True SysCmd acSysCmdInitMeter, "الاستعلام يقوم بالتحديث", 5000 DoCmd.SetWarnings False DoCmd.OpenQuery "q1" DoCmd.SetWarnings True PauseTime = 3: Start = Timer Do While Timer < Start + PauseTime DoEvents A = A + 1 SysCmd acSysCmdUpdateMeter, A Loop Application.SetOption "Show Status Bar", False SysCmd acSysCmdClearStatus Exit_أمر10_Click: Exit Sub Err_أمر10_Click: MsgBox Err.Description Resume Exit_أمر10_Click End Sub . وهذا الرابط فيه البرنامج المرفق ، يعني خذ منه الكود وخليه في برنامجك : http://www.access-programmers.co.uk/forums/attachment.php?attachmentid=32438&stc=1&d=1275923825 . . والنتيجة Notification بطريقة البرامج المحترفة ، فوق ساعة الكمبيوتر . جعفر 876.msg styles.mdb.zip BalloonToolTipSample.mdb.zip