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

نموذج منبثق - Pop-up Popup.mdb

حياك الله اخي @الشربيني 123 واياك

مشاركة مع اخي @ابو البشر مشكلة الجمع.accdb

ما شاء الله تبارك الله اهلا @ابا جودى نورت المنتدى

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

شكرا لك اخ فتح .....

نعم عادي مافيها شيئ DoCmd.Close acForm, "AT" DoCmd.Maximize

استخدم هذا ..... Dim q As Integer q = z If Me.v = q Then MsgBox "error1" Else MsgBox "error2" End If

هل هذا ما تريد أخي الكريم .... مشكلة الجمع.accdb

تفضل بالتنسيقات الشرطية ... فيمكنك استخدام هذه المعادلة =OR(AND($D11="أعزب",$H11>=75),AND($D11="متزوج",$H11>=60)) مستند 02.xlsx

حرب هذا الملف صفحة Combo_Sheet الصفحة Target ما زالت موجودة لكنها مخفية تم حماية المعادلات لعدم العبث بها عن طريق الخطأ اذا احببت ان تقوم بتعديل شيء ما اذهب الى الصفحة الرئيسية تجد هناك الاسم الذي اخترته من الشيت Combo_Sheet باللون الاخصر (كي لا تقوم بالتفتيش عنه بين كل الاسماء) al7aer2_iist_Combo.xlsm

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

ما تقول كدا من الصبح al7aer2_iist.xlsm

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

تمام جزاك الله خيرا

مشتاقين استاذ ابا جودي الغالي

مليون مبروك وخالص تحياتى القلبية

أحبك الذى أحببتني له

شكراً لكم جميعاً ❤️ سررت بتهنئتكم شكراً ابا جودى على المشاعر الطيبة ، ونحن نحبكم في الله ، وندعوا لكم جميعاً بالتوفيق والسداد ويجزكم الله خيرا الجزاء في الدنيا والآخرة على ما تقدمونه من خدمة وتسهيل على المسلمين.

رائع جدا استاذنا الفاضل اسأل الله ان يزدك من علمه وكرمه تحياتي

فى الملف رقم 2 البرنامج بيضيف السجلات القديمة فقط لكن لو دخلت سجلات جديدة فى جدول الاصناف مش بتظهر فى جدول جرد الفواتير

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

منور الدنيا كلها استاذنا الغالي @ابا جودى عودا حميدا حبيبنا .....

بارك الله فيك استاذ محمد وجزاك الله خير الثواب

اذا كان الملف الذي رفعته يعمل انقل بياناتك اليه (فقط محتوبات الصفحة الثانية) كما اذكرك بأنه كان بوجد في ملفك خلايا مدمجة تعيق عمل الكود قمت انا بازالتها أو بجب عليك تسمية النطاق (D9 D7 D5 )الخ..... باسم "Data_Rg" مع ازالة الخلايا المدمجة اولاً كما في الصورة المرفقة

تم اضافة 2 كود باسلوب مبسط الكود الاول للاصافة (تكتب ما تريد اضافته في الخلية D5 مع جميع البيانات ثم ثضغظ الزر "اضافة") تكرار الاسم غير مسموح والثاني للبحث (تكتب ما تريد البحث في الخلية F3 / اللون الأصفر/ ثم تضغط الزر "البحث عن الاسماء") اذا كان الاسم غير موجود تخرج لك رسالة بهذا الأمر Option Explicit Private Sub Cmd_Add_Click() Rem ------------------ Code for ADD --------------- Dim Last_2 As Integer Dim cont%, n%, m%, Ro% Dim ARR Dim First As Worksheet Dim Scd As Worksheet Set First = Sheets("Sheet1"): Set Scd = Sheets("Sheet2") n = Application.CountA(First.Range("Data_Rg")) m = First.Range("Data_Rg").Cells.Count If n <> m Then MsgBox "برجاء إدخال البيانات كاملة", vbCritical, "تنبيه" Exit Sub End If ARR = Split(First.Range("Data_Rg").Address(0, 0), ",") Last_2 = Scd.Range("B:B").Find("").Row cont = Application.CountIf(Scd.Range("B3:B" & Last_2), First.Range("D5").Value) If cont Then MsgBox "هذا الاسم موجود", vbCritical, "تنبيه" Exit Sub End If For Ro = LBound(ARR) To UBound(ARR) Scd.Cells(Last_2, 2).Offset(, Ro) = _ First.Range(ARR(Ro)) Next First.Range("Data_Rg").ClearContents End Sub Rem ------------------ end Of ADD --------------- '++++++++++++++++++++++++++++++ Rem ------------------ code for saerch ___________ Private Sub Cmd_Saerch_Click() Dim Last_2 As Integer Dim cont%, m%, Ro% Dim ARR Dim First As Worksheet Dim Scd As Worksheet On Error Resume Next If Sheet1.Range("F3").Value = "" Then MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "خطأ" Exit Sub End If Set First = Sheets("Sheet1"): Set Scd = Sheets("Sheet2") Last_2 = Scd.Cells(Rows.Count, 2).End(3).Row cont = Application.CountIf(Scd.Range("B3:B" & Last_2), _ First.Range("F3").Value) If cont = 0 Then MsgBox "هذا الاسم غير موجود", vbCritical, "تنبيه" Exit Sub End If ARR = Split(First.Range("Data_Rg").Address(0, 0), ",") m = Scd.Range("B1:B" & Last_2).Find(First.Range("F3").Value, lookat:=1).Row For Ro = LBound(ARR) To UBound(ARR) First.Range(ARR(Ro)) = _ Scd.Cells(m, 2).Offset(, Ro) Next End Sub Rem ------------------ End of saerch ___________ الملف مرفق al7aer2.xlsm

السلام عليكم أختنا الكريمة مرفق الملف به ماطلبتي إن شاء الله ملاحظة في مثل هذه الحال ، يمكنك حذف كثير من البيانات لتقليل حجم الملف علي الموقع يعني بدلا من بيانات أكثر من 10,000 طالب يكفي 100 أو 200 وفقط نأخذ المعادلة ونطبقها أنا عملت كده وبدلا من إرسال 27 أو 28 ميجا ، فقط 0.028 ميجا تجريب2.xlsx

بعد اذن الأستاذ علي اختصار للكود باستعمال الحلقة التكرارية Private Sub CommandButton1_Click() Dim Lrow As Integer Lrow = Sheets("data").Range("b10000").End(xlUp).Row + 1 Dim i% Dim Ar_Data(1 To 9) Dim Ar_Fan(1 To 9) Ar_Data(1) = "B": Ar_Data(2) = "C": Ar_Data(3) = "E" Ar_Data(4) = "F": Ar_Data(5) = "G": Ar_Data(6) = "H" Ar_Data(7) = "I": Ar_Data(8) = "J": Ar_Data(9) = "K" Ar_Fan(1) = "D5": Ar_Fan(2) = "D7": Ar_Fan(3) = "D11" Ar_Fan(4) = "D13": Ar_Fan(5) = "D15": Ar_Fan(6) = "G7" Ar_Fan(7) = "G9": Ar_Fan(8) = "G11": Ar_Fan(9) = "G13" For i = 1 To 9 Sheets("data").Cells(Lrow, Ar_Data(i)) = _ Sheets("fan").Range(Ar_Fan(i)) Sheets("fan").Range(Ar_Fan(i)) = vbNullString Next Sheets("data").Cells(Lrow, "D").Value = _ IIf(OptionButton1.Value = True, "ذكر", "انثى") OptionButton1.Value = "" OptionButton2.Value = "" End Sub

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

شكراً اباجودي هذا هو المطلوب بالضبط

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

حضرتك تريد اخفاء كل الصفوف ان كانت القيمة فى الحقل Total =0 او كانت فارغة لو انا قدرت افهم صح اتفضل DatabaseX.accdb

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

وعليكم السلام-يجب عليك جعل الكود هكذا .. وحاول معرفة الفرق البسيط والإضافة السهلة بين كودك وهذا الكود بارك الله فيك Private Sub CommandButton1_Click() Dim Lrow As Integer Lrow = Sheets("data").Range("b10000").End(xlUp).Row + 1 Sheets("data").Cells(Lrow, "b").Value = Sheets("fan").Range("d5").Value Sheets("data").Cells(Lrow, "C").Value = Sheets("fan").Range("D7").Value Sheets("data").Cells(Lrow, "D").Value = IIf(OptionButton1.Value = True, "ذكر", "انثى") Sheets("data").Cells(Lrow, "E").Value = Sheets("fan").Range("D11").Value Sheets("data").Cells(Lrow, "F").Value = Sheets("fan").Range("D13").Value Sheets("data").Cells(Lrow, "G").Value = Sheets("fan").Range("D15").Value Sheets("data").Cells(Lrow, "H").Value = Sheets("fan").Range("G7").Value Sheets("data").Cells(Lrow, "I").Value = Sheets("fan").Range("G9").Value Sheets("data").Cells(Lrow, "J").Value = Sheets("fan").Range("G11").Value Sheets("data").Cells(Lrow, "K").Value = Sheets("fan").Range("G13").Value MsgBox "تم اضافة البيانات بنجاح", vbInformation, "تأكيد" Sheets("fan").Range("D5").Value = "" Sheets("fan").Range("D7").Value = "" Sheets("fan").Range("D11").Value = "" Sheets("fan").Range("D13").Value = "" Sheets("fan").Range("D15").Value = "" Sheets("fan").Range("G7").Value = "" Sheets("fan").Range("G9").Value = "" Sheets("fan").Range("G11").Value = "" Sheets("fan").Range("G13").Value = "" OptionButton1.Value = "" OptionButton2.Value = "" End Sub forms1.xlsm

السلام عليكم ورحمة الله تعالى وبركاته اجمل واطيب التهانى والامانى استاذى الجليل واخى الحبيب تستحق كل الخيـر رغم انه قليل عليكم وكل كلمات الدنيا لن تكفيكم وتوفيكم قدركم

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

يهدف هذا البرنامج الى مراقبة ومتابعة المستندات المؤرشفة يدويا في ملفات بوكس والتي غالبا ما تكون مؤرشفة حسب تسلسل النظام وكل ملف يختص بنوع واحد من المستندات رابط التنزيل http://www.mediafire.com/file/8zf5d5zr89df56r/%D8%A8%D8%B1%D8%A7%D9%85%D8%AC_%D9%85%D8%AA%D8%A7%D8%A8%D8%B9%D8%A9.rar/file رابط التنزيل http://www.mediafire.com/file/8zf5d5zr89df56r/%D8%A8%D8%B1%D8%A7%D9%85%D8%AC_%D9%85%D8%AA%D8%A7%D8%A8%D8%B9%D8%A9.rar/file

بارك الله فيك استاذ حسين _ بعد اذنك ولإثراء الموضوع .. على ان يكون ايضاً الكود بهذا الشكل Private Sub CommandButton1_Click() If UserForm1.TextBox1.Value = "admin" And UserForm1.TextBox2.Value = 2020 Or UserForm1.TextBox1.Value = "ali" And UserForm1.TextBox2.Value = 456 Then Application.Visible = True UserForm1.Hide If UserForm1.TextBox1.Value = "admin" And UserForm1.TextBox2.Value = 2020 Then Sheet5.Select End If If UserForm1.TextBox1.Value = "ali" And UserForm1.TextBox2.Value = 456 Then Sheet1.Select End If Else MsgBox "بـرجاء مراجـعـة اســم المستخدم وكلمـة المـرور", , "Error" Label4.Caption = Label4.Caption - 1 If Label4.Caption = 0 Then ThisWorkbook.save Application.Quit End If End If End Sub شيت فاتورة مبيعات .xlsm

استخدم هذه الدالة UCase في الحدث المناسب في الحقل مثلا : عند فقدان التركيز أو بعد التحديث للحقل المطلوب field1 = UCase(field1)

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

واياك .... حياك الله

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

كان وضعت مثال للتطبيق .... على كل حال جرب الكود التالي .... أو ارفق ملفك للتعديل . On Error Resume Next If IsNull(Me.readtbl.Column(0)) Then MsgBox "The List Empty or Items in list not selected", vbCritical, "Caution" Exit Sub End If Me.ProgBar.Visible = True Dim x As Integer For x = x To 30000 Me.ProgBar.Value = x If x = 30000 Then Me.ProgBar.Visible = False End If Next x Dim i As Integer Dim tbl As String Dim SDest As String Dim SFileName As String SDest = Me.txtPath SFileName = Me.txtFileName For i = 0 To Me.readtbl.ListCount - 1 If Me.readtbl.Selected(i) = True Then tbl = Me.readtbl.Column(0, i) DoCmd.TransferSpreadsheet acExport, , tbl, SDest & "\" & SFileName & ".xlsx" End If Next i MsgBox "تم بحمد الله الانتهاء من عملية التصدير ", 0 + 64 + 1572864, "مبروك"

تم معالجة الامر بواسطة الكود ( الكود اوتوماتيكي يعمل بمجرد ما تختار اي رقم ) ولا حاجة لاستدعاءه بواسطة زر صفحة Salim من هذا الملف الكود Sub By_Macro() Dim s As Worksheet Dim D As Worksheet Dim F_rg As Range Dim ro% Set s = Sheets("Salim"): Set D = Sheets("Data") s.Cells(6, 4).Resize(, 5).ClearContents If s.Cells(6, 3) = vbNullString Then Exit Sub Set F_rg = D.Range("A1").CurrentRegion.Columns(1). _ Find(s.Cells(6, 3), LookIn:=xlValues, lookat:=1) If F_rg Is Nothing Then Exit Sub ro = F_rg.Row s.Cells(6, 4).Resize(, 5).Value = _ D.Cells(ro, 2).Resize(, 5).Value End Sub report_Ali_New.xlsm

هذا عمل من الصعب تنفيذه بالمعادلات جرب هذا الكود Option Explicit Sub Extract_Codes() Dim col As Object Dim i% Dim RoB%, RoD% Set col = CreateObject("System.Collections.ArrayList") With Sheets("Sheet2") i = 2 Do Until .Cells(i, 1) = vbNullString If Not col.Contains(.Cells(i, 2).Value) _ And .Cells(i, 2) <> "" _ And IsNumeric(.Cells(i, 2)) Then col.Add .Cells(i, 2).Value End If If Not col.Contains(.Cells(i, 4).Value) _ And .Cells(i, 4) <> "" _ And IsNumeric(.Cells(i, 4)) Then col.Add .Cells(i, 4).Value End If i = i + 1 Loop col.Sort .Cells(1, "I").CurrentRegion.ClearContents .Cells(1, "I").Resize(col.Count).Value = _ Application.Transpose(col.ToArray) End With End Sub الملف مرفق Saher.xlsm

بس اذا تكرمت اخي ما هي كلمة المرور جزاك الله كل خير

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

وعليكم السلام -فقط للحفظ التلقائى ... عليك بوضع هذا الكود فى حدث ThisWorkBook Private Sub Workbook_BeforeClose(Cancel As Boolean) If Saved = False Then ActiveWorkbook.Save End If End Sub Protect.xlsb

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