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

أ.عبدالعزيز محمد جرب المرفق عسى أن يكون ما طلبت .. عذرا إن كانت الطريقة قديمة شويتين .. ولكن الجودة بالموجوده 😃 Aziz.accdb

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

اخي الكريم يجب عليك تثبيت Framework 4.5 يرجى تجربة الملفات المرفقة Setup.rar Debug.rar

تم التعديل على الملف السابق كما تريد بالضبط .... وهذا حل اخر ان اردت يمكنك ذلك من خلال قائمة Data ثم تختار Subtotal إدراج صف تلقائى - 1.xlsm

بعد اذن اخي حسن مأمون بواسطة هذا الكود تستطيع اختصار 94 حلقة تكرارية (y=6 to 100) في كل دورة من الـــ X من 1 الى Lr اذن لوكان عدد الصفوف 100 صف فاننا نقوم بــ 94×100= 9400 حلقة تكرارية لا حاجه لها يمكن هنا استعمال الدالة Match او الدالة Find لتحديد العامود الذي نريد الصاق قيمة الخلية المطلوب ولا حاجة للدورة ثانية من الحلقات التكراية(y) كما لا ننسى تفريغ النطاق كله قبل مباشرة الكود بالعمل من خلال السطر السادس من الكود وبذلك نوفر الجهد و عدم حشو الذاكرة بشيء لاتستفيد منه اضافة الى تحجيم الملف هذا مثال عن الماكرو كما اتصوره هنا Sub MY_code() Dim x%, lr%, col%, Last_col% Dim Find_cel As Range Last_col = Cells(2, Columns.Count).End(1).Column lr = Cells(Rows.Count, "e").End(3).Row Range("F3").Resize(lr, Last_col - 5).Clear For x = 3 To lr Set Find_cel = Rows(2).Find(Cells(x, "e"), lookat:=1) If Not Find_cel Is Nothing Then col = Find_cel.Column Cells(x, col) = Cells(x, "D") End If Next With Range("F3").Resize(lr, Last_col - 5).SpecialCells(2) .Borders.LineStyle = 1 .Interior.ColorIndex = 6 .Font.Bold = True .HorizontalAlignment = 3 End With End Sub الملف مرفق My_value.xlsm

تفضل يمكنك وضع استخدام هذا الكود بحدث الصفحة , بحيث يقوم بإدراج صف فارغ بمجرد إدخال تاريخ مختلف Private Sub Worksheet_Change(ByVal Target As Range) Dim L& If Target.Address = Cells(Rows.Count, 5).End(xlUp).Address Then If IsDate(Target) And IsDate(Target(0)) Then If Target.Value2 <> Target(0).Value2 Then Application.EnableEvents = False Application.ScreenUpdating = False Target.EntireRow.Insert If IsEmpty(Target(-2)) Then L = Target(-1).Row Else L = Application.Max(6, Target(-1).End(xlUp).Row) With Target(0).EntireRow .Interior.ColorIndex = 4 .Interior.Pattern = xlSolid .Columns("B:C").Formula = "=SUM(B" & L & ":B" & Target(-1).Row & ")" .Cells(4).Value2 = "إجمالى اليوم " End With Application.ScreenUpdating = True Application.EnableEvents = True End If End If End If End Sub إدراج صف تلقائى - 1.xlsm

تفضل 2021 IN المشتريات.xlsx

عملت طريقة Tag ونجح Dim ctl As Control For Each ctl In Me.Controls If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox Then If ctl.Tag = 1 Then ctl.Value = Null End If End If Next ctl الطريقة : تذهب لخصائص الحقل تبويب| غير ذلك | علامة | ضع رقم 1 في الحقول التي تريد تفريغها مع استثناء الترقيم التلقائي . تفريغ الحقول.mdb

تمت معالجة الامر Option Explicit Sub MY_Data_New() Application.ScreenUpdating = False Dim SH_from As Worksheet Dim T As Worksheet Dim rg_to_Patse As Range Dim Rt%, MY_max%, ro%: ro = 4 Set T = Sheets("Total") Set rg_to_Patse = T.Range("A3").CurrentRegion Rt = rg_to_Patse.Rows.Count If Rt > 1 Then Set rg_to_Patse = rg_to_Patse.Offset(1).Resize(Rt - 1) Else Set rg_to_Patse = T.Range("B4").Resize(, 5) End If rg_to_Patse.Clear For Each SH_from In Sheets If SH_from.Name <> T.Name Then MY_max = Application.Max(SH_from.Range("A:A")) SH_from.Cells(3, 1).Resize(MY_max, 6).Copy With T.Cells(ro, 1) .PasteSpecial (xlPasteValues) .PasteSpecial (xlPasteFormats) End With ro = ro + MY_max End If Next SH_from With T.Range("A3").Resize(ro - 4, 6) .Sort key1:=Range("b3"), Header:=1 End With Application.ScreenUpdating = True arraNge_all End Sub '+++++++++++++++++++++++++++++++++++ Sub arraNge_all() Application.ScreenUpdating = False Dim nro% Dim MM% nro = Cells(Rows.Count, 1).End(3).Row Dim color_rg As Range For MM = 4 To nro If Range("B" & MM).Interior.ColorIndex = 2 Or _ Range("B" & MM).Interior.ColorIndex = -4142 Then GoTo Next_MM If color_rg Is Nothing Then Set color_rg = Range("B" & MM).Resize(, 5) Else Set color_rg = Union(color_rg, Range("B" & MM).Resize(, 5)) End If Next_MM: Next If color_rg Is Nothing Then GoTo Contenu color_rg.Copy Range("B" & nro + 1) color_rg.EntireRow.Delete Contenu: Range("B4", Range("B3").End(4)).Offset(, -1).Formula = _ "=IF(B4="""","""",MAX($A$3:A3)+1)" With Range("A3").CurrentRegion .Value = .Value .Borders.LineStyle = 1 End With Range("A4").Select Set color_rg = Nothing create_borders Application.ScreenUpdating = True End Sub '+++++++++++++++++++++++++++++++++++ Sub create_borders() Dim My_sh As Worksheet, r For Each My_sh In Sheets If My_sh.Name <> "Total" Then r = My_sh.Cells(Rows.Count, 2).End(3).Row My_sh.Cells.Borders.LineStyle = xlNone My_sh.Range("a2").Resize(r - 1, 6).Borders.LineStyle = 1 End If Next End Sub الملف الأخير Laste_flie.xlsm

تفضل لك اكثر مما طلبت نظاما - 1.xlsm

الله يفتح عليك معلمنا الجليل / @kha9009lid

بعد اذن اخواني لكي تتعدد الخيارات اخي الكريم لكي يسهل عليك الامر استخدم الكود التالي Dim dbsNorthwind As DAO.Database Dim rstShippers As DAO.Recordset Set dbsNorthwind = CurrentDb Set rstShippers = dbsNorthwind.OpenRecordset("Table_Name") With rstShippers .AddNew !User_Name = [text1] !Password = [text2] .Update End With

اعجبتني هذه المقوله : قَالَ ابْنُ الْمُبَارَكِ: لَا يَزَالُ الْمَرْءُ عَالِمًا مَا طَلَبَ الْعِلْمَ، فَإِذَا ظَنَّ أَنَّهُ قَدْ عَلَمَ؛ فَقَدْ جَهِلَ

انا الذى عليه شكركم اخوانى واساتذتى بارك الله فيكم اضافه جميله باستخدام تاج الترقيم اخى صالح @ابوآمنة ولكن ايضا يضيف السجل الفارغ برقمه والكود التالى بدون استخدام التاجات خالص فالمشاركه السابقه لى Dim ctl As Control On Error Resume Next For Each ctl In Me.Controls If ctl.ControlType = acComboBox Or ctl.ControlType = acTextBox Then 'Add other control types here ctl.Value = "" End If Next ctl Set ctl = Nothing DoCmd.GoToRecord , , acNewRec فقمت باستخدام حذف السجل الفارغ المضاف واعاده الفهرسه هذا ما توصلت اليه حتى لا يكون هناك سجلات فارغه وجزاهم الله خيرا اساتذتنا ومعلمينا فى اول تعديل لظهور الخطأ وشغال تمام وملاحظتك لى عندما قلت لم يشتغل معى وارفقت مثالك اتضح لى الخطأ ما بين مثالى الذى اعمل عليه ومثالك المرفق وننتظر صاحب السؤال ليقول هل تم تجربه الاكواد ع قاعده البيانات الخاصه به وهل تم طلبه تمتعت واستفدت كثيرا من مشاركتكم معى وانتظر ايضا اخى على @Ali Sadiq للتعقيب وشرح كوده فضلا لا امرا وهل فعلا محتاج التاج كما اشتغل معى بوضع التاجات ام هناك شىء لم افهمه وارجو منكم قبول عذرى وجهلى فمازلت اتعلم واحاول ان افهم منكم اخوانى واساتذتى بارك الله فيكم وجزاكم الله كل خير تقبلوا تحياتى وتمنياتى لكم وللجميع بالتوفيق بالنجاح احبكم فالله

وعليكم السلام اخي الكريم راجع اعدادات اللغة العربية للنظام انشاء الله ستحل المشكلة

شكراً إضافة جميلة يا أخي أحمد وإعادة الفهرس من جديد أضفت تجربتي شاهد المرفق 'إضافة الحقول المستثناه ID.Tag = 2 For Each ctl In Me.Controls If ctl.ControlType = acComboBox Or ctl.ControlType = acTextBox Then If ctl.Tag <> 2 Then ctl.Value = Null End If End If Next ctl بدون إضافة التاج في خصائص الحقل يتم إضافته في الكود . تفريغ الحقول(2).mdb

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

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

توصل بالسلامه ان شاء الله اخى صالح جزاك الله خيرا فى ملحوظه مهمه : بان الكود يعمل لدى لان حقل الترقيم التلقائى بالكود وليس ترقيم تلقائى كما بمثالك اخى صالح جزاك الله خيرا اخى @kaser906 على مشاركتك لنا قد افرغ النص بالتاج اخى كاسر @kaser906 مع الابقاء على حقل الرقم بالفعل والكود التالى الذى توصلت اليه يقوم بنفس العمل يقوم بتفريغ النصوص ما عدا حقل الترقيم وكذلك من غير وضع التاجات فى حين هناك الكثير من مربعات النص ثم الذهاب لسجل جديد Dim ctl As Control On Error Resume Next For Each ctl In Me.Controls If ctl.ControlType = acComboBox Or ctl.ControlType = acTextBox Then 'Add other control types here ctl.Value = "" End If Next ctl Set ctl = Nothing DoCmd.GoToRecord , , acNewRec ولكن يفرغ الحقول وينشىء حقل فارغ واخر تعديل لى مع الترقيم التلقائى مع مثال اخى صالح @ابوآمنة Dim ctl As Control On Error Resume Next For Each ctl In Me.Controls If ctl.ControlType = acComboBox Or ctl.ControlType = acTextBox Then 'Add other control types here ctl.Value = "" End If Next ctl Set ctl = Nothing Me.RecordSource = "" DoCmd.SetWarnings False DoCmd.RunSQL "DELETE Temp3.f1, Temp3.f2, Temp3.F3, Temp3.ID FROM Temp3 WHERE (((Temp3.f1) Is Null)) OR (((Temp3.f2) Is Null)) OR (((Temp3.F3) Is Null));" DoCmd.RunSQL "DROP INDEX ID ON Temp3;" DoCmd.RunSQL "alter table Temp3 drop ID;" DoCmd.RunSQL "alter table Temp3 Add column ID autoincrement;" DoCmd.RunSQL "CREATE UNIQUE INDEX ID on Temp3(ID) ;" DoCmd.SetWarnings True Me.RecordSource = "Temp3" DoCmd.GoToRecord , , acNewRec وفى انتظار شروحاتكم مرفق المثال تقبلوا تحياتى وتمنياتى لكم وللجميع بالتوفيق تفريغ الحقول(1).mdb

انا ع طريق سفر فور وصولي بمشيئة الله سأطلع ع المثال

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

شكرا جدا استاد على محمد على مجهودك العظي❤️م

بعد اذن استاذي الكريم Ali Mohamed Ali جرب الكود Sub testttttttttt() Dim x, y Dim lr Application.ScreenUpdating = False lr = Cells(Rows.Count, "e").End(3).Row For x = 3 To lr For y = 6 To 100 If Cells(x, "e").Text = Cells(2, y) Then Cells(x, y).Value = Cells(x, "d").Value End If Next Next Application.ScreenUpdating = True End Sub

Dim ctl As Control For Each ctl In Me.Controls If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox Then If ctl.Value <> "" Then ctl.Value = "" End If End If Next ctl جرب هذا الكود

أضم صوتي للزميل في السؤال عن كيفية تشغيلك لبرنامجك على الأندرويد و جزاكم الله خيرا

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

استاذ / @أحمد الفلاحجى الله يفتح عليك فعلا قد اتضحت الصورة الآن بارك الله فيك وجعله في ميزان حسناتك الأن فى انتظار استاذنا / @kha9009lid

الله يجزاكم بالخير حبايبي دعوه لكم من ظهر قلب

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

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

الاخ khairi ali علي الله توكلت سأبدأ العمل ولكني لا احيذ المفاجأت في الطلبات بعد بدء العمل علي الموضوع فهل هناك اي طلبات او تعليمات اخري الله المستعان لقد تم عمل اللازم بنجاح ولكنك دخلت المنتدي ولم تكلف نفسك بالرد شكرا لك تفضل اخي شاهد المرفق Test_1.xls

أستاذ عماد محمد عبد العزيز لماذل لا تقوم بالضغط على الإعجاب ؟!!! 💙 وأعتقد ان هذا اقل ما يقدم لصاحب الفضل عليك بعد ربنا فى حل مشكلتك

اتفضل اخى بعد ما تختار التاريخ وتخرج هيرقم تلقائى تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق تجربة.rar

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

قم بانشاء شيت جديد باسم Salim ونفذ هذا الكود Option Explicit Sub Del_Exta_Rows() Dim S_sh As Worksheet 'source sheet Dim T_sh As Worksheet 'target sheet Dim Lrs% 'laste row in source sheet Dim Cols% 'laste column in source sheet Set S_sh = Sheets("Recovered_Sheet1") Set T_sh = Sheets("Salim") T_sh.Cells.Clear Lrs = S_sh.Cells(Rows.Count, 1).End(3).Row Cols = S_sh.Cells(1, Columns.Count).End(1).Column S_sh.Cells(1, 1).Resize(Lrs, Cols). _ SpecialCells(xlCellTypeConstants).Copy T_sh.Cells(1, 1).PasteSpecial (xlPasteAll) Application.CutCopyMode = False With T_sh.Range("a1").CurrentRegion .Columns.AutoFit .Borders.LineStyle = 1 .Cells(1).Select End With End Sub الملف مرفق ( شيت Salim ) DEL_ROWS.xlsm

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

اهلا وسهلا استاذي ابو بسملة الحقيقة الطريقة التي استخدمها تختلف قليلا عن هذه الطريق وان كانت تشترك معها في استخدام اكواد او وسوم xml الطريقة متعبة وتحتاج الى معرفة بهذة الوسوم او على الاقل المعرفة بلغة ترميز النصوص المتشعبة html الخاصة ببناء صفحات الانترنت لوجود تشابه بينهما طريقتي باختصار كتابة الوسوم ووضع id لكل امر اما طريقة تنفيذ الامر فعن طريق وحدة نمطية مع ان النتيجة رائعة الا ان الطريقة متعبة جدا وسوف احاول بعون الله ان اضع موضوع يشرح الطريقة واعتذر اذاكان الرد غير مفيد واستعير عبارة جميلة لاخي واستاذي الفاضل @essam rabea "انا راجل عجوز" فانا فعلا رجل عحوز والشروحات مرهقة جدا

وعليكم السلام-تفضل لك ما طلبت Classeur4.xlsx

بعد تنفيذ الماكرو الق نظرة على الشيتات ترى كل شيء قد تم كما تريد

تفضل هذه فكرة مبدئية تم عملها على VB.NET مرفق ملف التثبيت و ملف المشروع بالكامل اسم المستخدم : 1 كلمة المرور : 1 WindowsApplication1.zip publish.zip

الحلقة الثانية: أكواد الطباعة و الخصائص و... سوف نتطرق في هذه الحلقة إلى الأكواد التي تمكننا من طباعة صفحة الويب و حفظها و عرض خصائص الصفحة و غيرها... 1- كود طباعة الصفحة: Me.WebBrowser3.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DODEFAULT 2- كود معاينة طباعة الصفحة: Me.WebBrowser3.ExecWB OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DODEFAULT 3- كود عرض خصائص الصفحة: Me.WebBrowser3.ExecWB OLECMDID_PROPERTIES, OLECMDEXECOPT_DODEFAULT 4- كود حفظ صفحة الويب: Me.WebBrowser3.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT 5- كود تنسيق الصفحة: Me.WebBrowser3.ExecWB OLECMDID_PAGESETUP, OLECMDEXECOPT_DODEFAULT 6- كود عنوان رابط الصفحة: MsgBox Me.WebBrowser3.LocationName 7- كود رابط الصفحة: MsgBox Me.WebBrowser3.LocationURL 8- كود فتح الصفحة الإفتراضية للمتصفح: Me.WebBrowser3.GoHome 9- كود فتح صفحة البحث: Me.WebBrowser3.GoSearch 10- كود فتح صندوق التصفح: هذا الكود يقوم بفتح صندوق لإدخال رابط صفحة ويب جديدة Me.WebBrowser3.ExecWB OLECMDID_OPEN, OLECMDEXECOPT_DODEFAULT 11- كود تخطي رسائل الأخطاء التي تظهر من الأداة عند التصفح: Me.WebBrowser3.Silent = True وهذا المرفق بعد الإضافات الجديدة webbroser.rar

بارك الله فيك أستاذنا الفاضل علي محمد علي وبعد إذنك أرى أن يتم أيضا الكود في حدث ThisWorkBook Private Sub Workbook_BeforeClose(Cancel As Boolean) show_menu End Sub حتى يعود الإكسيل للوضع الافتراضي بعد غلق هذا الملف فعندما يتم فتح ملف آخر لا يجد الشريط مخفى ويحدث هذا الأمر على الأكثر في إصدرات الأوفيس القديمة Hide.xlsm

تفضل لك ما طلبت هذه الأكواد فى مديول عادى Sub hide_menu() Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"",False)" End Sub Sub show_menu() Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"",True)" End Sub وهذا الكود فى حدث ThisWorkBook Private Sub Workbook_Open() hide_menu End Sub وذلك كما بالملف Hide.xlsm

السلام عليكم حبيت اعمل مشاركة بسيطة وياكم بعض اكواد VBA لكل من يبي يعمل واجهة نظامية تحياتي ADO.rar

تم معالجة الامر انظر الى الصفحة New_Sheet من هذا الملف الباسورد 500 Salim 2018 With_combo.xlsm

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

وعلشان اصطياد الخطأ يشتغل ، السطر الثاني يخبر الكود اين يذهب عندما يجد الخطأ: Private Sub أمر2_Click() On Error GoTo err_Report فهل عندك هذا السطر في الكود جعفر

عندما وضعت الكود في برنامجي ظهر عندي هذا الخطأ عندما وجد شرط ينطبق اي هناك سجل في في الجدول Tbl_month وكان قيمة القل exchange اكبر من صفر ولم يجد سجل في الجدول Tbl_Month_exchange

ان شاء الله تكون الصورة هذي توضح المطلوب

المثال الثاني مثل السابق مع الحماية باستخدام كلمة سر و هي 1234 لأن الحالة السابقة يمكن فك الحماية من القوائم مباشرة Sub Pr1() ActiveSheet.Protect Password:=1234, DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub Sub Pr2() x = InputBox("please enter PAssword '1234'", "Password", 123) If x <> 1234 Then MsgBox "Sorry You are not Allowed !!! " Exit Sub End If ActiveSheet.Protect Password:=1234, DrawingObjects:=False, Contents:=False, Scenarios:=False End Sub UnprotectSheetPass.xls