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

تفضل كما تريد .... بالتنسيق الشرطى حمادة.xls

هناك معادلة اسهل =COUNTIF($M$44:$M$59,I4)>0

جرب هذا الكود : Function Remove_Extras(myValue As String) As String Dim x() As String Dim j As Integer Dim mySpace As String For j = 1 To 999 'remove all the extra characters at the end of the line If Right(myValue, 1) = Chr(7) Or _ Right(myValue, 1) = vbCr Or _ Right(myValue, 1) = vbLf Or _ Right(myValue, 1) = vbCrLf Then myValue = Mid(myValue, 1, Len(myValue) - 1) Else Exit For End If Next j 'now remove the empty lines myValue = Replace(myValue, Chr(7), vbCrLf) myValue = Replace(myValue, vbCr, vbCrLf) myValue = Replace(myValue, vbLf, vbCrLf) x = Split(myValue, vbCrLf) For j = 0 To UBound(x) 'remove the extra spaces on: x(j) = LTrim(x(j)) 'remove the left spaces If Len(x(j)) < 2 Then Else 'remove the extra spaces on: x(j) = LTrim(x(j)) 'remove the left spaces 'separate the text from vbcrlf, Remove the extra spaces, then attache vbcrlf to it 'only if the right character is a spcae mySpace = Mid(x(j), 1, Len(x(j)) - 1) If Right(mySpace, 1) = " " Then x(j) = Trim(mySpace) & vbCrLf End If Remove_Extras = Remove_Extras & x(j) End If Next j Remove_Extras = Replace(Remove_Extras, Chr(11), vbCrLf) 'remove all VT characters End Function جعفر

انا مطمئن لما اتعامل مع عمالقة مثلك ومثل اخونا الكبير ابو الكرم ، وكل اللي تقولوه على راسي 🙂 بس كنت خايف من الحرفين الباقين ، ترى الدكتور حسنين مو سهل ، يسحبنا شوي شوي 😁 جعفر

بتاتا البته لن ننزلق بعون الله حقوق الاخرين محفوظة قانونا وشرعا

ما يحتاج اصطياد لكسر محرر الاكواد مجرد حرف واحد b=x وهذا برنامج اخونا بعد كسره

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

ممكن تستخدم هذا التحايل ..... شغل التقرير وضع رقم 1 Footer.mdb

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

شوف المرفق. ما فهمت !! خليني اشوف اللي عملته 1311.4.Data.accdb.zip

تفضل يا سيدي 🙂 . جعفر 1311.4.Data.accdb.zip

بناء على بحث في هذه النقطة و في موقع فرنسي كانت النتيجة التالية تقليل المسافات في السلسلة تم النشر في 13 آب (أغسطس) 2012 خاصة بعد استيراد البيانات ، ينتهي بنا الأمر أحيانًا بمسافات متعددة بين الكلمات. هذه وظيفة تزيل بشكل فعال هذه المسافات المتعددة في واحدة. الوظيفة في VBA Public Function ReduireEspaces(ByVal Chaine As String) As String Const DoubleEspace As String = " " Const Espace As String = " " While InStr(1, Chaine, DoubleEspace, vbBinaryCompare) > 0 Chaine = Replace(Chaine, DoubleEspace, Espace, , , vbBinaryCompare) Wend ReduireEspaces = Chaine End Function مع كل تمريرة للحلقة ، يتم تقليل المسافة المزدوجة إلى واحد. على سبيل المثال ، لتقليل 3 مسافات متجاورة إلى واحدة ، يتم تنفيذ الحلقة مرتين. في الحلقة الأولى ، يُنظر إلى 3 مسافات متجاورة على أنها مسافتان + مسافة واحدة ، ومن ثم يتم تقليل المساحة إلى مسافة واحدة + مسافة واحدة. ثم تجد الحلقة الثانية مسافتين متجاورتين يتم تقليلهما بعد ذلك إلى مسافتين. للتذكير ، نزيل المسافات في بداية السلسلة باستخدام الدالة LTrim () ، والمسافات الموجودة في نهاية السلسلة بواسطة RTrim () والكل بواسطة Trim () (أو LTrim $ ، RTrim $ ، Trim $ لسلسلة من نوع String). مثال على الاستخدام في نافذة Run VBE: 'Attendu: Un espace sinon rien! ?ReduireEspaces("Un espace sinon rien!") و المثال الذي قمت رفعه أعلاه قمت بتجربته و أضفت العديد من المسافات بين الكلمات و بعد تنفيذ الاستعلام نجح في إرجاع المسافات الى موقعها العادي دون أن يتأثر التنسيق أو ينقص من الجملة أو الكلمة ربما يمكن إضافة هذه الخاصية الى الكود الذي قمت بتصميمه.

والله يا استاذة انا فهمي على قدي جربي لعله المطلوب النتيجة في استعلام 5 4.accdb

السلام عليكم 🙂 هل افهم انك تحتاج التقارير بهذه الطريقة: . 1. . 2. . جعفر

جرب هذه المحاولة تجهيز التجحميل.xlsm

ههههه لا يا استاذي ابو الكرم انا حذر جدا 🌹 ما يحتاج يسحبنا يا ابا عبدالله الدكتور حسنين استاذ في الهندسة العكسية

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

توجد طرق وبرامج ، ولكن قصدك ان قوانين المنتدى لا تسمح برفع مثل هذه الامور ، للحماية الفكرية لصاحب الموضوع 🙂 وقصدك انه لا يوجد شي لتخطي أو الغاء باسورد VBA أبداً ، اذا كان البرنامج بصيغة mde او accde 🙂 جعفر

عليكم السلام، قم بترتيبها بالاكسل أولاً ثم قم بنقلها الى الأكسس.

السلام عليكم ورحمة الله تم تعديل الكود ارجو ان يكون هو المطلوب Sub FinalResult() Const Res = "ناجح ومنقول إلى الصف السابع بتقدير" Dim ws As Worksheet Dim LR As Long, I As Long, x As Integer Dim Mad As String t = Timer Application.ScreenUpdating = False Set ws = Sheets("ك.د.سد") On Error Resume Next ws.Range("F" & I + 3).ClearContents LR = ws.Range("C" & Rows.Count).End(3).Row I = 11 Do While I <= LR If ws.Cells(I, 33) = "ناجح" Then ws.Cells(I + 3, 6).Value = Res & "" & ws.Cells(I, 29).Value ElseIf ws.Cells(I, 33) = "له دور ثان في" Then x = 38 Do While x <= 50 Mad = Mad & "-" & ws.Cells(I, x).Value ws.Cells(I + 3, 6).Value = ws.Cells(I, 33).Value & " " & Mad x = x + 2 Loop End If Mad = "" I = I + 4 Loop Application.ScreenUpdating = True 'MsgBox Round(Timer - t, 2) End Sub

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

تفضل: تم اضافة : 'remove the extra spaces on: x(j) = LTrim(x(j)) 'the Left x(j) = RTrim(x(j)) 'the Right Function Remove_Extras(myValue As String) As String Dim x() As String Dim j As Integer For j = 1 To 999 'remove all the extra characters at the end of the line If Right(myValue, 1) = Chr(7) Or _ Right(myValue, 1) = vbCr Or _ Right(myValue, 1) = vbLf Or _ Right(myValue, 1) = vbCrLf Then myValue = Mid(myValue, 1, Len(myValue) - 1) Else Exit For End If Next j 'now remove the empty lines myValue = Replace(myValue, Chr(7), vbCrLf) myValue = Replace(myValue, vbCr, vbCrLf) myValue = Replace(myValue, vbLf, vbCrLf) x = Split(myValue, vbCrLf) For j = 0 To UBound(x) 'remove the extra spaces on: x(j) = LTrim(x(j)) 'the Left x(j) = RTrim(x(j)) 'the Right If Len(x(j)) < 2 Then Else Remove_Extras = Remove_Extras & x(j) End If Next j Remove_Extras = Replace(Remove_Extras, Chr(11), vbCrLf) 'remove all VT characters End Function جعفر

وعليكم السلام ورحمة الله وبركاته حياك الله اخي الحبيب ابوعبدالله الفكرة اخي ابوعبدالله كالتالي 1 - فتح قاعدة البيانات في وضع الخاص 2 - إزالة كلمة المرور 3 - تحويل قاعدة البيانات من accdb الى accde 4 - تعيين كلمة مرور من جديد لكلتا القاعدتين accdb و accde هذا الموديل للخطوات 1 ، 2 ، 4 Public Sub Set_Pass(sDBName As String, soLdPass As String, Optional sNewPass As String = "") Dim db As DAO.Database On Error GoTo Err: Set db = OpenDatabase(sDBName, True, False, ";PWD=" & soLdPass) db.NewPassword soLdPass, sNewPass Exit Sub Err: Resume Next End Sub وهذا الكود في زر امر لتنفيذ جميع الخطوات Dim app As New Access.Application Dim DB_Full_Name As String Dim DB_Directory As String Dim oLdPass As String, NewPass As String oLdPass = 777 '1 And 2 Set_Pass Me.DB_File, oLdPass, oLdPass Set_Pass Me.DB_File, oLdPass, "" DB_Full_Name = Me.DB_File DB_Directory = Mid(DB_Full_Name, 1, Len(DB_Full_Name) - 6) & ".accde" '3 app.SysCmd 603, DB_Full_Name, DB_Directory '4 oLdPass = "" NewPass = 777 Set_Pass Me.DB_File, oLdPass, NewPass Set_Pass DB_Directory, oLdPass, NewPass تحياتي

هدية للموقع برنامج الجمعيات الخيرية الرقم السرى 1515 جنتى المعدل بنك الدم.rar

في الملف المرفق تجدون برنامج أعجبني كثيرا جربوه لن تخسروا شيئا، يحلل كل محتويات قاعدة البيانات و في النهاية تجد ملخص لقاعدة البيانات يمكن أن يكون وسيلة عمل للتعامل مع قاعدة البيانات الشرح المفصل تجدونه في الموقع التالي أضغط هنا لزيارة الموقع Analyzer_2K_081113_16_9p__MDE_PPS_DOC_TXT.zip

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

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

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

بعد ادن استادي واتراء للموضوع هذه طريقة متواضعة التنفيذ بالفورم تاريخ التقاعد.xlsm

السلام عليكم ورحمة الله وبركاتة برنامج شئون الطلاب بالمدارس .... هديه متواضعه للعاملين بالتربيه والتعليم فى انتظار ملاحظاتكم .. كلمة السر 1111 http://www.gulfup.com/?o4iEZn شئون الطلاب .rar

السلام عليكم ورحمة الله وبركاته السادة الافاضل مشرفي واعضاء منتدانا العظيم استفساري هو كود للبحث والتأكد من عدم خلو حقل الكمية لكل صنف في النموذج الفرعي بمعني عند الضغط علي رز الحفظ يقوم بالبحث فى سجلات النموذج الفرعي وعند وجود حقل كمية فارغ يقوم بانذاري بذلك وبالتالـي لا يقبل الحفظ مرفق صورة توضيحية والقاعدة . ولكم جزيل الشكر .,,, Test.rar

الصق هذه الجملة في حدث النقر للزر في النموذج الرئيسي Dim rs As Recordset Set rs = Me.F_ordersubform.Form.RecordsetClone rs.MoveLast R = rs.RecordCount rs.MoveFirst For i = 1 To R If IsNull(rs!Qty) Then MsgBox "اكتب العدد" Exit Sub End If rs.MoveNext Next rs.close Set rs = Nothing

يحتوى برنامج الفيزيو 2010 على خاصية اضافة الملاحظات و علامات المراجعة Mark up و لكن للاسف لا يحوي امكانيات متقدمة مثل برنامج الوورد للتحكم فى طباعتها و لكن يوجد حل بديل عن طريق الماكرو حيث يتم انشاء مربع نص و نسخ قائمة بالتعديلات اليه و ذلك بجوار الرسم المصدر http://support.microsoft.com/kb/898514/en-us و هذا هو الكود Public Sub GetComments() Dim pagMarkup As Visio.Page Dim pag As Visio.Page Dim shp As Visio.Shape Dim sText As String Dim iRow As Integer Set pag = Visio.ActivePage sText = "Reviewer" & vbTab & "Date" & vbTab & "Comment" If pag.PageSheet.SectionExists(Visio.visSectionAnnotation, Visio.visExistsAnywhere) Then For iRow = 0 To pag.PageSheet.RowCount(Visio.visSectionAnnotation) - 1 sText = sText & vbCrLf & pag.Document.DocumentSheet.CellsSRC(Visio.visSectionReviewer, pag.PageSheet.CellsSRC(Visio.visSectionAnnotation, iRow, Visio.visAnnotationReviewerID).ResultIU - 1, Visio.visReviewerInitials).ResultStr("") sText = sText & pag.PageSheet.CellsSRC(Visio.visSectionAnnotation, iRow, Visio.visAnnotationMarkerIndex).ResultIU sText = sText & vbTab & Format(pag.PageSheet.CellsSRC(Visio.visSectionAnnotation, iRow, Visio.visAnnotationDate).ResultIU, "ddddd") sText = sText & vbTab & pag.PageSheet.CellsSRC(Visio.visSectionAnnotation, iRow, Visio.visAnnotationComment).ResultStr("") Next iRow End If For Each pagMarkup In pag.Document.Pages If pagMarkup.Type = visTypeMarkup Then If pagMarkup.OriginalPage = pag Then If pagMarkup.PageSheet.SectionExists(Visio.visSectionAnnotation, Visio.visExistsAnywhere) Then sText = sText & vbCrLf sText = sText & vbCrLf & pag.Document.DocumentSheet.CellsSRC(Visio.visSectionReviewer, pagMarkup.ReviewerID - 1, Visio.visReviewerName).ResultStr("") For iRow = 0 To pagMarkup.PageSheet.RowCount(Visio.visSectionAnnotation) - 1 sText = sText & vbCrLf & pag.Document.DocumentSheet.CellsSRC(Visio.visSectionReviewer, pagMarkup.PageSheet.CellsSRC(Visio.visSectionAnnotation, iRow, Visio.visAnnotationReviewerID).ResultIU - 1, Visio.visReviewerInitials).ResultStr("") sText = sText & pagMarkup.PageSheet.CellsSRC(Visio.visSectionAnnotation, iRow, Visio.visAnnotationMarkerIndex).ResultIU sText = sText & vbTab & Format(pagMarkup.PageSheet.CellsSRC(Visio.visSectionAnnotation, iRow, Visio.visAnnotationDate).ResultIU, "ddddd") sText = sText & vbTab & pagMarkup.PageSheet.CellsSRC(Visio.visSectionAnnotation, iRow, Visio.visAnnotationComment).ResultStr("") Next iRow End If End If End If Next pagMarkup Dim iAutoSize as Integer 'new iAutoSize = pag.AutoSize 'new pag.AutoSize = 0 'new Set shp = pag.DrawRectangle(-pag.PageSheet.Cells("PageWidth").ResultIU, 0, 0, pag.PageSheet.Cells("PageHeight").ResultIU) pag.AutoSize = iAutoSize 'new shp.AddSection visSectionUser 'new shp.AddNamedRow visSectionUser, "msvNoAutoSize", visTagDefault 'new shp.CellsU("User.msvNoAutoSize").FormulaU = 1 'new shp.Cells("Para.HorzAlign").Formula = "0" shp.Cells("VerticalAlign").Formula = "0" shp.Name = "Reviewers Comments" shp.Text = sText End Sub

وتسهيلا على الإخوة من طول المعادلة قمت بعمل دالة تقوم بالغرض المطلوب بسهولة Function MasDateAdd(interval As String, number As Double, dt As Date) As Date MasDateAdd = DateAdd(interval, number, dt) End Function وطريقة استدعائها =MasDateAdd("m",14,a1) وتعني إضافة 14 شهر (m) إلى التاريخ الموجود في الخلية a1 و ينبغي علينا معرفة الحروف التي يجب كتابتها في interval وهي كالتالي yyyy ----> year , q ----> quarter , m ----> month , d ----> day , ww -----> week , w -----> weekday , y -------> day of year , h ----> hour , n ------> minute , s ---------> second أتمنى أن تكون الدالة موفقة في تأدية المطلوب ملحوظة الدالة تعمل بالزيادة والنقص بمعنى أنه يمكننا طرح عدد معين من الشهور أو الأيام من تاريخ معين مثال =MasDateAdd("m",-14,a1) ولا تنسو أخاكم محمد صالح من صالح دعائكم

السلام عليكم المعادلة شغالة أخي انت لم تضف اليها الدوال الثلاثة YEAR ,MONTH ,DAY اليك المرفق تفضل وجرب New Microsoft Excel Worksheet (T).rar