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

وعليكم السلام 🙂 في ذيل النموذج ، في حقول المجاميع ، استخد التالي كمصدر لبيانات الحقل: مجموع نعم =Sum(IIf([mtwajd]=-1,1,0)) مجموع لا =Sum(IIf([mtwajd]=0,1,0)) جعفر

العفو اخي الفاضل لقد حاولت تبسيط الكود الاول ليتم فهمه ربما تحتاج يوما ما للتعديل تفضل اخي اليك كود اخر يقوم بنفس المهمة لاكن حاول تجنب وضع علامة / بين الكلمات يمكنك استبدالها ب علامة (-) مثلا وسوف يشتغل معك الكود بكفاءة عالية بالتوفيق Sub Test_MH3() Dim a, b Dim I As Long, II As Long, LR As Long Dim j As Integer Dim ObjDic As Object Set ObjDic = CreateObject("Scripting.Dictionary") Dim K, T LR = Cells(Rows.Count, "A").End(3).Row a = Range("A2:D" & LR) For I = LBound(a, 1) To UBound(a, 1) ObjDic(a(I, 1)) = a(I, 2) & "/" & a(I, 3) & "/" & a(I, 4) Next I LR = Cells(Rows.Count, "e").End(3).Row b = Range("E2:E" & LR) ReDim Preserve b(LBound(b, 1) To UBound(b, 1), 1 To 5) For I = LBound(b, 1) To UBound(b, 1) For Each K In ObjDic.keys If K Like "*" & b(I, 1) & "*" Then T = Split(ObjDic(K), "/") b(I, 1) = K For II = 0 To UBound(T, 1) b(I, 2 + II) = T(II) Next II Exit For End If Next K Next I Cells(2, "F").Resize(UBound(b, 1), 4) = b End Sub نسخة من نسخة officene _3.xlsm

هذه إحدى الطرق: مثال 48_02.accdb

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

تفضل اخي هذا مثال لطلبك Sub TEST_mh5() Dim ws As Worksheet Dim LR As Long Set ws = Worksheets("sheet2") Application.ScreenUpdating = False LR = ws.Range("B" & Rows.Count).End(xlUp).Row With ws.Range("c2:c" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,1,0)" .Value = .Value With ws.Range("d2:d" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,2,0)" .Value = .Value With ws.Range("E2:E" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,3,0)" .Value = .Value With ws.Range("F2:F" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,4,0)" .Value = .Value With ws.Range("G2:G" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,5,0)" .Value = .Value End With End With End With End With End With End Sub جلب البيانات 2.xlsm

أخي حمدي جرب الكود الان سبب تكرار الارسال هو هذه الاسطر Set IE = CreateObject("InternetExplorer.Application") IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text=""*" & " || *" & Me.myname.Value & "*" & " || *" & Me.msg.Value & "*" & " || " & Me.attach.Value & "* || " & "المرسل : *" & Me.sub & "*" & "& app_sent =0" Pause 3 SendKeys "{TAB}" Call SendKeys("~", True) اليك الكود كاملا بعد التعديل Dim IEE As Object Dim SQL As String Dim fso As Object Dim fldrname As String Dim fldrpath As String Dim Mytoname As String Dim stname1 As String Dim rs As DAO.Recordset Set rs = CurrentDb.OpenRecordset("email") rs.MoveLast: rs.MoveFirst Dim IE As Object DoCmd.RunCommand acCmdSaveRecord If Nz(DCount("SelectRow", "email", "SelectRow = 'R'"), 0) = 0 Then MsgBox "يجب اختيار المرسل اليه اولا", vbCritical + vbMsgBoxRight, "تنبيه" Exit Sub End If Me.myname.SetFocus If IsNull(Me.msg) Then MsgBox "لايوجد نص للارسال", vbCritical + vbMsgBoxRight, "تنبيه" Exit Sub End If If IsNull([email1].Form![phone_number]) Then MsgBox "لايوجد رقم هاتف", vbCritical + vbMsgBoxRight, "تنبيه" Exit Sub End If DoCmd.OpenForm "email4", acNormal 'Set IE = CreateObject("InternetExplorer.Application") 'IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text=""*" & " || *" & Me.myname.Value & "*" & " || *" & Me.msg.Value & "*" & " || *" & Me.attach.Value & "* || " & "المرسل : *" & Me.sub & "*" & "& app_sent =0" 'Pause 3 'SendKeys "{TAB}" 'Call SendKeys("~", True) If Not rs.BOF And Not rs.EOF Then rs.MoveFirst While (Not rs.EOF) If rs.Fields("SelectRow") = "R" Then Mytoname = rs.Fields(0) stname1 = rs.Fields("toname") Dim strMSG As String strMSG = " || *" & Me.myname.Value & "*" & " || *" & Me.msg.Value & "*" & " || *" & Me.attach.Value & "* || " & "المرسل : *" & Me.sub strMSG = ReplaceLineBreaks(strMSG) Set IE = CreateObject("InternetExplorer.Application") IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text=""*" & strMSG & "*" & "& app_sent =0" Pause 3 Set IE = Nothing Set IEE = Nothing Dim objClipboard As Object Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") objClipboard.SetText (MyFile) objClipboard.PutInClipboard Pause 5 SendKeys "+{TAB}" Call SendKeys("{Enter}", True) Pause 2 Call SendKeys("{Enter}", True) Pause 5 Langauge ELanguage.en Pause 5 Call SendKeys("^v", True) Call SendKeys("{Enter}", True) Pause 5 Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") objClipboard.SetText ReplaceLineBreaks(Me.msg) objClipboard.PutInClipboard Pause 1 Call SendKeys("^v", True) Pause 5 Call SendKeys("{Enter}", True) Pause 1 DoCmd.SetWarnings False DoCmd.RunSQL "UPDATE email SET[SendStuts]='تم الارسال' , SelectRow ='T' WHERE [ID]=" & Mytoname DoCmd.SetWarnings True SendKeys "+{TAB}" SendKeys "+{TAB}" SendKeys "+{TAB}" SendKeys "+{TAB}" SendKeys "+{TAB}" SendKeys "+{TAB}" End If rs.MoveNext Wend End If rs.Close Set rs = Nothing MsgBox "تم الارسال" End Sub ' =================================(وهذه دالة لجعل الواتسأب يقبل السطور الجديدة في النص المرسل) Function ReplaceLineBreaks(text As String) As String ReplaceLineBreaks = Replace(text, vbCrLf, " %0a ") ReplaceLineBreaks = Replace(ReplaceLineBreaks, Chr(10), " %0a ") ReplaceLineBreaks = Replace(ReplaceLineBreaks, Chr(13), " %0a ") End Function المعذرة أخي لم أجرب الكود على البرنامج وذلك لانشغالي . جرب الكود هذا وان شاءالله عندما يسمح الوقت ساكون معكم . بالتوفيق

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

تفضل Public Function SubSalary3(fld As String) Dim i As String i = DLookup("[النسبة]", "tp2", "[المنصب]='" & fld & "'") SubSalary3 = i End Function نناديه هكذا Me.a5 = SubSalary3(a4)

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

الاصح بين الجدولين هو tp2 لانه قابل للزيادة وبالنسبة لطلبك هذا السطر يقوم بالمهمة ضعه في حدث بعد التحديث لحقل المنصب Me.a5 = DLookup("[النسبة]", "tp2", "[المنصب]='" & Me.a4 & "'") اذا تريده عن طريق وحدة نمطية عامة سوف ازودك بالجملة البرمجية

السلام عليكم تم عمل المطلوب في الملف المرفق، وذلك باستعمال الكود نفسه من موضوعك السابق الذي رابطه أمر طباعة الكل مع بعض التعديل... aشهادات .xlsm

مجال الاجتهاد مفتوح للجميع 🙂 أنا مشغول جدا هذي الفترة .. 🌹

الاخ AbuuAhmed الاخ jjafferr يسعد لي صباحكم بارك الله فيكم اوفيتم واكفيتم حصلنا على الاجابة كود ودالة ولايسعني غير ان اقول جزاكم الله خيرا

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

وعليكم السلام ورحمة الله وبركاته اخي الكريم...هي لا يوجد لدي ملف وانما هي فكرة طرات ببالي واريد اعرف كيف ممكن حلها: اختصار شرح الفكرة وهي كتالي: نفترض عندك خلية وتحتوي على العدد 10 طبعا لنفترض ان هذة القيمة تتغير باستمرار في كل دقيقة.. لنفترض ان التغيرات التي حدثت خلال الدقيقة كانت على النحو التالي.. 10 ثم صارت 13 ثم 9 ثم 16 ثم 7 هنا نريد ان نحسب القيمة الحالية من القيمة السابقة مع كل تغيير حدث وستكون النتيجة كتالي طبعا القيم الموجبة وهي تحدث عنما تكون القيمة الحالية اعلى من القيمة السابقة ، وعكس ذلك هي القيم السالبة اول تغير كان من 10 الى 13................. اذا الفرق هو 3 نقاط بالموجب ثاني تغيير كان من 13 الى 9 ................اذا الفرق هو 4 نقاط بالسالب ثالث تغيير هو من 9 الى 16 .................اذا الفرق هو 7 نقاط بالموجب رابع تغيير هو من 16 الى 7 ..................اذا الفرق هو 9 نقاط بالسالب اذا المجموع الكلي للقيمة الموجبة هي 10 والمجموع الكلي للقيمة السالبة هي 13 طبعا كل تغيير يحدث سواء موجب او سالب يتم اضافته للمجموع الكلي الموجب للقيم الموجبة او السالب للقيم السالبة. اذا هناك اي شي غير مفهوم ممكن اعيد شرحه من جديد

لا يمكنني تخمين موضع الحقول التي سيتم اظافتها يمكنك تعديله بنفس الطريقة عند اظافة حقول جديدة Sub TEST_MH2() Dim MT As Worksheet Dim lr As Long Set MT = Worksheets("sheet4") Application.ScreenUpdating = False lr = MT.Range("A" & Rows.Count).End(xlUp).Row MT.Range("F2:i" & lr).ClearContents With MT.Range("F2:F" & lr) .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,1,0)" .Value = .Value With MT.Range("G2:G" & lr) .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,2,0)" .Value = .Value With MT.Range("H2:H" & lr) .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,3,0)" .Value = .Value With MT.Range("I2:I" & lr) .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,4,0)" .Value = .Value End With End With End With End With Application.ScreenUpdating = True End Sub نسخة من نسخة officene _2.xlsm

ممكن ...... جرب الاستعلام القديم .... 751محاسبة2018 مستودعات - Copy_Backup.rar

الكود طباعة الكل يعود إلى الصفحة 1 بعد أن يكمل عملية الطباعة... وبالنسبة للعدد الذي يصل إلى الآخر فهذا لا أستطيع أن أعرفه لأن البيانات Source غير موجودة في الملف.. الكارتة1.xlsm

السلام عليكم ورحمة الله محاولة في الملف... Book1.xlsm

شكرا لك عمي جعفر ، كنت أعاني من هذي المشكلة وما عارف كيف أحلها .. 😅 والحين بعد ما عرفت .. عملت هذي الدالة لاستبدال فواصل الفقرات بالرمز "%0a" واللي تقوم بعمل السطر الفاصل بين الفقرات كما يريده الواتسأب : ' =================================(وهذه دالة لجعل الواتسأب يقبل السطور الجديدة في النص المرسل) Function ReplaceLineBreaks(text As String) As String ReplaceLineBreaks = Replace(text, vbCrLf, " %0a ") ReplaceLineBreaks = Replace(ReplaceLineBreaks, Chr(10), " %0a ") ReplaceLineBreaks = Replace(ReplaceLineBreaks, Chr(13), " %0a ") End Function وتستخدم كالتالي قبل ما تدخل في كود الإرسال : Dim MSG as String MSG = ReplaceLineBreaks(Me.MsgText) جربتها في برنامج مرسال الواتسأب ونجحت ولله الحمد 😊

وعليكم السلام 🙂 في الواتساب ، للإنتقال للسطر التالي ، لا تستعمل vbcrlf او chr(10) او chr(13) ، وانما استعمل "%0a" وكذلك تم ترجمة هذه الجزئية من موقع الواتساب: https://faq.whatsapp.com/539178204879377/?locale=en_US يتيح لك WhatsApp تنسيق النص داخل رسائلك. يرجى ملاحظة أنه لا يوجد خيار لتعطيل هذه الميزة. مائل لجعل رسالتك مائلة ، ضع شرطة سفلية على جانبي النص: _نص_ بالخط العريض لجعل رسالتك غامقة ، ضع علامة النجمة على جانبي النص: *نص* يتوسطه خط لتخطي رسالتك ، ضع علامة تلدة على جانبي النص: ~ نص ~ مونوسبيس لفرد رسالتك ، ضع ثلاث علامات خلفية على جانبي النص: ```نص``` ملحوظة: بدلاً من ذلك ، يمكنك استخدام الاختصارات على Android و iPhone. Android: اضغط مع الاستمرار على النص الذي تدخله في حقل النص ، ثم اختر غامق أو مائل أو المزيد. انقر على "المزيد" لاختيار خط يتوسطه خط أو مسافة أحادية. iPhone: اضغط على النص الذي تدخله في حقل النص> تحديد أو تحديد الكل> B_I_U. ثم اختر Bold أو Italic أو Strikethrough أو Monospace. جعفر

وهكذا الناتج السنوات المفقودة وآخر سنة سداد.accdb

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

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاخوة الكرام بعض التعديلات البسيطة ربما تلبي المطلوب طلب وتعديل3.xlsm

حياك الله أخي (Abu Rafat) .. تم التعديل أرجو التجربة. مقارنة (1).xls

وعليكم السلام ورحمة الله تعالى وبركاته العد.xlsx

كل الشكر لك أخي @عمر ضاحى 🙂 وأستغل هذه المناسبة الجميلة لعرض طريقة جديدة تعلمتها لكتابة الأكواد مع قيم True & False .. جرب كتابة الأكواد بهذه الطريقة : Private Sub Command31_Click() Me.ApprovedOK = Not ApprovedOK Me.imgApproved.Visible = ApprovedOK End Sub Private Sub Form_AfterUpdate() Me.imgApproved.Visible = ApprovedOK End Sub Private Sub Form_Current() Me.imgApproved.Visible = ApprovedOK End Sub والنتيجة نفسها طبعا .. مع زيادة إمكانية التراجع عن الموافقة 🙂

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

شوف يا استاذ عبد اللطيف روعة البرنامج فى اى يؤدى المطلوب منه بمعالجة البيانات بسرعة و بدقة و بأقل استخدام للعوامل البشرية التى قد تؤدى الى الأخطاء وقمة الجمال فى البساطة