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

بعد اذن اخي علي هذا الملف (تم تفيير بعض الاشياء في الملف لحسن عمل الكود) الكود Option Explicit Sub filter_me() If ActiveSheet.Name <> "احصاء العمر" Then GoTo Leave_Me_Alone Application.ScreenUpdating = False ActiveSheet.Range("b5:I20").ClearContents Dim clas_arr() Dim s%, k%, m%, n% m = 2: n = 3 ReDim clas_arr(1 To 4) clas_arr(1) = "الاول": clas_arr(2) = "الثاني" clas_arr(3) = "الثالث": clas_arr(4) = "الرابع" For s = 1 To 4 For k = 5 To 20 Range("filter_range").AutoFilter Field:=10, Criteria1:=k Range("filter_range").AutoFilter Field:=7, Criteria1:="=" & clas_arr(s) Range("filter_range").AutoFilter Field:=5, Criteria1:="ذكر" Cells(k, m) = Sheets("بيانات أساسية").Cells(1, "M").Value Range("filter_range").AutoFilter Field:=10, Criteria1:=k Range("filter_range").AutoFilter Field:=7, Criteria1:="=" & clas_arr(s) Range("filter_range").AutoFilter Field:=5, Criteria1:="انثى" Cells(k, n) = Sheets("بيانات أساسية").Cells(1, "M").Value Next m = m + 2: n = n + 2 Next Leave_Me_Alone: Erase clas_arr Range("filter_range").AutoFilter Application.ScreenUpdating = True End Sub الملف مرفق salim_filter.xlsm

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

وهي تجربتي 100% كذلك ، ولعدة اسباب فانا استعمل نوعين من الماكرو فقط ، ماكرو ليفتح عند فتح البرنامج ، ويجب ان يكون اسمه autoexec ، والماكرو الآخر هو لوقف اسخدام ازرار الكيبورد للدخول في الكود وقائمة كائنات البرنامج ، اما بقية برامجي فاستخدم VBA هذه ليست رموز ، انما لأنك كاتب اسم النموذج بالعربي (ونحن دائما نقول: يجب ان تكتب اسماء الكائنات جميعها بالانجليزية ، الجداول والنماذج والاستعلامات والتقارير والماكرو ، واسماء الحقول) ، فالبرنامج كتب ارقام الحروف بالـ ascii code ، ولم يستعمل الامر chr بسبب استعمالك للحروف العربية ، فإستخدم chrW ومن الرابط المرفق تحصل على ارقام الحروف العربية ، مثلا ChrW(1608) = و http://sites.psu.edu/symbolcodes/languages/mideast/arabic/arabicchart/ جعفر

بعد إذن أخينا العزيز شيفان يمكنك استعمال هذا الاستعلام SELECT B FROM Tab1 WHERE B NOT IN(SELECT A FROM tab1);

جرب هذا الملف tp_salim.xlsx

احسن الله لك اساذ علي منكم نتعلم انتم أساتذة رائعون بمعنى الكلمة استفدت كثيرا من هذا الصرح الكبير انتم كرماء بعطاءكم وزادكم الله علما ً قوق علمكم مني كل الاحترام والتقدير لحضرتك وكلماتك الرائعة وهي دافع لي

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

وعليكم السلام النموذج معطوب ، فلا يمكنك الاستفادة منه ، لذا عملت لك نسخه من كائناته في نموذج جديد بإسم PaymentEach ، ولكن للعلم ، قد تكون احد كائنات النموذج هي السبب في جعل النموذج معطوب ، فالافضل ان تعمل النموذج من جديد!! استطعت/تستطيع فتح النموذج القديم هكذا: نموذجك اسمه PaymentEach_OLD ، لما تنقر عليه مرتين تحصل على هذه الرساله (انا عملت ماكرو بإسم تكبير والذي كان يطلبه البرنامج ،وطلبت منه يعطين هذه الرساله) : . سينفتح النموذج ، ثم انقر بالفأرة اليمين ، فتحصل على هذه الرسالة . انقر ok ، وستحصل على القائمة التالية ، فإنقر على Design view . فينفتح لك النموذج في وضع التصميم . وكما اخبرتك ، فإنه معطوب ولا تستطيع استعماله ، وانما استعمل النوذج الآخر الذي عملت لك. جعفر dd.zip

الف شكر على بك جاتزاك الله خير على تعبك ولكن المعادلات لا تعمل فعتد تحميل المرفق و فتحه وجدت لجنة 10 مادة الجبر و الفراغية و الأسماء مظبوطة ولما غيرت رقم اللجنة أو إسم المادة لم يجلب أى بيانات بل وضع لى كلمة ?name#

بارك الله فيك استذنا ali mohamed ali لم انتبه الي الاجابة لان كل الاسماء وضعتهم من نفس مكان اقامة ونفس رقم الحساب.

تفضل Function chk_BeforeUpdate(Cancel As Integer) On Error GoTo err_chk_BeforeUpdate Dim ctl As Control Dim rst As DAO.Recordset Dim dbs As DAO.Database Dim fName As String: Dim myCriteria As String Dim A0 As String: Dim A1 As String: Dim A2 As String Set ctl = Me.ActiveControl fName = "[" & Mid(ctl.Name, 1, Len(ctl.Name) - 1) & "-مادة" & Right(ctl.Name, 1) & "]" '[الاثنين-مادة1] myCriteria = "[" & ctl.Name & "]=" & Chr(39) & ctl.Value & Chr(39) 'A0 = DLookup(ctl.Name, "Teacher Class", myCriteria) 'A1 = DLookup(fName, "Teacher Class", myCriteria) 'A2 = DLookup("[NAMEe]", "Teacher Class", myCriteria) Set dbs = CurrentDb Set rst = dbs.OpenRecordset("Select * From [Teacher Class] Where " & myCriteria) A0 = rst(ctl.Name) A1 = rst(fName) A2 = rst!namee ' If A0 > 0 Then Beep If MsgBox("...هذا الفصل " & ctl.Name & "..لديه مادة.." & vbCrLf & _ " باسم : " & A1 & vbCrLf & _ " للمدرس : " & A2, _ vbYesNo + vbCritical + vbMsgBoxRight, "تنبيه") = vbNo Then Me.Undo Cancel = True End If ' End If Exit_chk_BeforeUpdate: rst.Close: Set rst = Nothing: dbs.Close Exit Function err_chk_BeforeUpdate: If err.Number = 3021 Then Resume Next Else MsgBox err.Number & vbCrLf & err.Description End If End Function جعفر

تم التعديل على الملف لاظهار قائمة منسدلة مطاطة (تستجيب لاي تغيير / اضافة/ مسح / تعديل ) في البيانات tp_salim1.xlsx

تفضل اخى الكريم-ولكن اجابة استاذنا الكبير سليم صحيحة تماما tp-1.xlsx

الأخ الكريم @ابو زاهر المرفق لا يحتوي على نماذج يستعمل فيها الوحدة النمطية لذا أي اقتراح سيكون بدون تجربة وعلى حسب فهمي المتواضع للمطلوب جرب تعديل الشرط الأخير في الكود إلى Else If Year(Date) > Year(Date - 1) Then Next_Seq = 0 Else Next_Seq = Nz(DMax("Mid([Rjmfatwra], 2)", "AfwtIar", "Mid([Rjmfatwra], 1, 1) = '" & t & "'"), 0) End If Next_Seq = t & Format(Next_Seq + 1, "0000000") End If

اساتذتي الافاضل Shivan Rekany أ / محمد صالح لكم مني جزيل الشكر

قم بتغيير مصدر الكومبوبوكس الى استعلام وبها كل الحقول المطلوبة وفي محرر الاكواد عند تغيير الكومبوبوكس استخدم هذا الكود ME.X1 = ME.EmployeeName.Column(3) غير الرقم 3 الى رقم الحقل المطلوب الرقم 3 هو حقل رقم 4 في الاستعلام اذا تتغيره الى رقم 0 هو رقم حقل الاول في الاستعلام واذا ما فهمت ما هو قصدي تقدر تبحث عن المنتدى بها مثال كتير على ذلك او ارفق نسخة مصغرة من قاعدة بياناتك لكي نعمل تعدديل عليه

نعم اخي برمجة VBA افضل بكثير من الماكرو وهذا راي الشخصي وعن تجربة

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

نعم لاحظت ذلك وقمت بتغير المعادلة جزيل الشكر وبالنسبة للموضوع الثاني على راحتك وشكرا لك في الحالتين ان قمت بالحل او لم تقم بالحل ( جزيل الشكر )

لاحظ المعادلة التي ادرجتها لك في الصفحة "بيانات أساسية" العامود G لا لزوم للمعادلة التي كانت (طويلة و مرهقة للاكسل و تتطلب عامود اضافي) =MID($D5,1,SEARCH("-",$D5)-1) بالنسية للموضوع ستدعاء بيانات من شيتين ومن اعمده بعيده ووضعها في شيت الترحيل سافكر بالامر لاحقاً (حسب الوقت)

لقد قمت بحله بطريقة ثانية ما هو رأيك بالحل aamir.xlsm ابدعت أستاذ سليم حاصبيا انا عاشق لـ الاكواد شكرا لك ابدعت أستاذ سليم حاصبيا انا عاشق لـ الاكواد شكرا لك

لقد قمت بحله بطريقة ثانية ما هو رأيك بالحل aamir.xlsm

جزاك الله خيرا ً أستاذ ali mohamed ali وجعل الله هذا العمل في ميزان حسناتك

تفضل أخى الكريم احصاء عدد التلاميذ المسجلين حسب الصف والجنس والعمر.xlsm

وعليكم السلام ما يظهر لديك في الماكرو هو نتيجة فقدان اسم النموذج وقد حصل مع كثيرا سابقا عندها استبدلت برمجة VBA بدل الماكر ولم يحدث شي الا اذا كان للخبراء اخوانا رأي آخر وكل التقدير والاحترام لهم...

السلام عليكم اخي الكريم شوف المرفق هل تنفع هذه الطريقة ؟ تحياتي وحده نمطيه.rar

اولا شكرا لك استاذنا @أبو آدم قم بفتح القاعدة بيانات وافتح احد نماذج في وضع تصميم واضغط على كونترول و حرف جي الانكليزية ctrl + G سيفتح لك هذه النافذة في الاسفل نافذة كتابة الاكواد كما مبينة في الصورة قم بكتابة هذه الجملة واضغط على انتر لكي يتم تفعيل خصائص الورقة CommandBars("Property Sheet").Enabled = True واذا تريد عدم التفعيل اكتب هذا CommandBars("Property Sheet").Enabled = false واضغط على انتر تقبلوا تحياتي

تفضل Option Compare Database Dim trycount As Integer Private Sub Cansel_Click() On Error GoTo Handle_Error [Forms]![frm-UserLogon].Visible = False If MyUser.Valid Then DoCmd.close ElseIf MsgBox("هل ترغب بمغادرة البرنامج؟", 4 + 32, "تأكيد الخروج") = 6 Then DoCmd.Quit Else [Forms]![frm-UserLogon].Visible = True End If Exit_Process: Exit Sub Handle_Error: MsgBox Err.Number & vbCrLf & Err.Description Resume Exit_Process End Sub Private Sub Form_Load() trycount = 0 End Sub Private Sub LoginBT_Click() On Error Resume Next Dim LogUser As New CUser If trycount > 3 Then MsgBox " من حُسن إسلام المرء تركه ما لا يعنيه ", vbOKOnly + vbMsgBoxRight + vbInformation, "تحذير !" MsgBox " سيتم إغلاق البرنامج الآن ،،، يرجى مراجعة المبرمج ", vbOKOnly + vbMsgBoxRight + vbInformation, "تحذير !" DoCmd.Quit ElseIf IsNull(Me.user) Then MsgBox (" فضلاً يجب أن تقوم بإدخال اسم المستخدم ") Me.user.SetFocus ElseIf IsNull(Me.pass) Then MsgBox (" فضلاً يجب أن تقوم بإدخال كلمة السر ") Me.pass.SetFocus ElseIf Len(Trim(Me.pass)) > 20 Then MsgBox (" يجب ألا تتجاوز كلمة السر عشرين حرف أو رقم") Me.pass.SetFocus '------- اسير الشروق ------ مستخدم مخفى للدخول لنموذج تفعيل والغاء الشيفت واخفاء واظهار الجداول --------- ElseIf [user] = "admin" And [pass] = "2015" Then DoCmd.close DoCmd.OpenForm "MSysEdit" ElseIf [user] = "superadmin" And [pass] = "2015" Then DoCmd.close DoCmd.OpenForm "Users Ability", acNormal '------- اسير الشروق ------ مستخدم مخفى للدخول لنموذج تفعيل والغاء الشيفت واخفاء واظهار الجداول --------- Else LogUser.UserName = Me.user LogUser.pass = Me.pass DoCmd.OpenForm "data" If LogUser.Valid Then Set MyUser = LogUser DoCmd.close acForm, "frm-userlogon" Else MsgBox " اسم المستخدم أو كلمة السر غير صحيحة ،،، يرجى إعادة المحاولة ", vbOKOnly + vbMsgBoxRight + vbInformation, "تحذير !" trycount = trycount + 1 End If End If End Sub Private Sub Permissions_Click() On Error Resume Next Dim LogUser As New CUser If trycount > 3 Then MsgBox " من حُسن إسلام المرء تركه ما لا يعنيه ", vbOKOnly + vbMsgBoxRight + vbInformation, "تحذير !" MsgBox " سيتم إغلاق البرنامج الآن ،،، يرجى مراجعة المبرمج ", vbOKOnly + vbMsgBoxRight + vbInformation, "تحذير !" DoCmd.Quit ElseIf IsNull(Me.user) Then MsgBox (" فضلاً يجب أن تقوم بإدخال اسم المستخدم ") Me.user.SetFocus ElseIf IsNull(Me.pass) Then MsgBox (" فضلاً يجب أن تقوم بإدخال كلمة السر ") Me.pass.SetFocus ElseIf Len(Trim(Me.pass)) > 20 Then MsgBox (" يجب ألا تتجاوز كلمة السر عشرين حرف أو رقم") Me.pass.SetFocus Else LogUser.UserName = Me.user LogUser.pass = Me.pass If LogUser.Valid Then Set MyUser = LogUser DoCmd.OpenForm "Users Ability", , , , , acDialog Me.user = Null Me.pass = Null LogUser = Null Else MsgBox " اسم المستخدم أو كلمة السر غير صحيحة ،،، يرجى إعادة المحاولة ", vbOKOnly + vbMsgBoxRight + vbInformation, "تحذير !" trycount = trycount + 1 End If End If End Sub Private Sub user_Exit(Cancel As Integer) 'استخراج رقم اليوزرد 'UN = (DLookup("[SN]", "Users", " deCode([UName],'User')= user ")) End Sub Private Sub ChangePassword_Click() Dim LogUser As New CUser If trycount > 3 Then MsgBox " Of a good Muslim, one left which does not concern ", vbOKOnly + vbMsgBoxRight + vbInformation, "Caution !" MsgBox " The program will be closing now ،،، Please check with the programmer - Mohamed Essam ", vbOKOnly + vbMsgBoxRight + vbInformation, "Caution !" DoCmd.Quit ElseIf IsNull(Me.user) Then MsgBox (" You must enter a user name ") Me.user.SetFocus ElseIf IsNull(Me.pass) Then MsgBox (" You must enter the password ") Me.pass.SetFocus ElseIf Len(Trim(Me.pass)) > 20 Then MsgBox (" Shall not exceed twenty password letter or number") Me.pass.SetFocus Else LogUser.UserName = Me.user LogUser.pass = Me.pass If LogUser.Valid Then Set MyUser = LogUser DoCmd.OpenForm "Change password", acNormal Else MsgBox " Username or password is incorrect ،،، Please try again ", vbOKOnly + vbMsgBoxRight + vbInformation, "Caution !" trycount = trycount + 1 End If End If End Sub قم باستبدال كل الكود بداخل نموذج الدخول بهذا لاننى لم استطع ارفاقها بسبب كبر المساحة وبطي الانترنت لدى . واذا امكن نبذه عن مشروعك والبصمة .

اخى ما الاضافة او التطوير الذى تريدة فهذا جيد حتى الان

الاخ Alawani بعد السلام ..... يرجى اعادة المشاركة (مع عدم تكرارها) و ذلك كي يستفيد منها اكبر عدد من المشاركين مع ذكر الحل وعنوانه

تفضل وقل ربي زدني علما.rar

لعد م مسح البيانات احذف هذا الجزء من الكود Sheet1.Range("A3:C3") = "" لتوسيع النطاق غير عمود C الي اى عمود تريدة لزيادة عرض النطاق ولطول النطاق هنا 50000 ممكن تزوده برده azsh = Sheet2.Range("c50000").End(xlUp).Row + 1 يمكن عمل الكود بالطريقتين بموديل او بدون موديل لو بدون موديل ممكن تحط الكود داخل الزر من المطور ,, ادراج ,, زر نوعه activeXcontrol دبل كليك على الزر وانت فى وضع المصمم مرفق الملف يعمل بدون موديل tr7eel.rar

أخيراً ظهرت على شاشات المنتدى فينك يا حاج يوسف ..ليك وحشة يا كبير .. تقبل وافر تقديري واحترامي