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

وعليكم السلام ورحمة الله محاولة في الملف المرفق.... ملف لاوفيسينا.xlsx

Please upload a sample file of the expected output that you need exactly

السلام عليكم ورحمة الله وبركاته.. من المعروف ان الواتس اب يسمح لك بارسال 5 رسائل فقط في كل مرة يعني لو كان لدينا 15 شخص نريد ان نرسل له رسالة علينا ان نقوم باعادة توجيه الرسالة 3 مرات كل مرة 5 اشخاص.. قمت بعمل اداة صغيرة في الـ NET. لتقوم بهذه المهمة. صورة مشروع الاكسس: قم بتحديد الاشخاص الذين تريد ارسال الرسالة لهم مع وضع نص الرسالة مع امكانية تحديد الكل يمكنك شروط البرنامج بحسب ماتراه مناسباً. النتيجة: ملاحظة يجب ان يكون برنامج الواتس اب موجود في جهاز الكومبيوتر واهم ملاحظة هي يجب كتاب رقم الواتس اب الذي تريد ان ترسل له الرسالة كما يظهر في البرنامج، مثال: لتحميل الواتس اب من الرابط الاتي: https://www.whatsapp.com/download لا تنسوني ووالدي من صالح دعائكم. تم بحمد الله. Whatsapp-Message-Sender.rar

السلام عليكم ورحمة الله تعالى وبركاته الشرح الاتى لا يخص الأكسس بصفة خاصة ولكن لحماية حذف القاعدة او اى ملف داخل مجلد او المجلد الذى يحتوى قاعدة البيانات بالخطأ اولا نقوم بعمل مجلد جديد ونعطيه الاسم الذى نريد على سبيل المثال نضع مجلد جديد داخل القطاع D ونعطى المجلد اسم BackDB نقوم بتحديد المسار ونقوم بنسخه فيكون D:\Test\BackDB ولو كان اسم المجلد من مقطعين مثل Back DB سوف يكون المسار نسخ المسار الى ملف نصى ونقوم بتعديله ليكون D:\Test\Back_DB بعد ذلك نقوم بفتح موجه الاومر DOS ونقوم بكتابة او لصق الامر الاتى cacls D:\Test\BackDB /P everyone:n ولو اسم المجلد من مقطعين يكون cacls D:\Test\Back_DB /P everyone:n ثم نضغط على المقتاح Enter من لوحة المقاتيح ثم نضغط على المفتاح Y من لوحة المفاتيح كما هو موضح فى الصورة بعد ذلك نغلق موجه الاوامر DOS ونذهب الى المجلد ونقوم بالضغط عليه كليك يمين ونختار Properties تظهر لنا النافذة الاتية نحدد التبويب Security ثم نضغط بعد ذلك على Advanced كما هو موضع بالصورة ثم بعد ذلك تظهر لنا النافذة الاتية نقوم بالتحديد اولا كما هو فى الخطوة رقم 1 بالصورة ثم بعد ذلك كما هو بالخطوة رقم 2 نقوم بالضغط على Edit ثم بعد ذلك تظهر لنا النافذة الاتية نقوم بالضعط على Show Advanced Permissions ثم بعد ذلك تظهر لنا النافذة الاتية 1- فى الـ Type نختار Allow 2- فى اختيارات الـ Permissions نقوم بإزالة التأشير من على الاتى Delete Delete Subfolders and files لتصبح الاعدادت كما بالشكل الاتى ثم نضغط OK الان انسخ قاعدة البيانات داخل المجلد او اى ملفات تخاف من فقدانها جرب حذف الملفات لن يتم حذفها حاول حذف القاعدة كذلك لن يتم حذفها كذلك اقتح القاعدة واضف اليها بيانات او عدل او احذف منها اى بيانات سوف تعمل القاعدة بشكل طبيعى جدا لو اردت حذف المجلد او اى شئ بداخلة فقط استخدم الامر الاتى فى موجه اوامر الـ DOS cacls D:\Test\BackDB /P everyone:f وبعد حذف ما تريد يمكنك اعادة الخطوات ان اردت ارجاع الحماية مرة اخرى انتهى الشرح دمتم فى امان الله...

😂 قصدك جماعة البخور

الفكرة بسيطة ورائعة ولاتخطر على بال احد ...الا القليلين امثال استاذ @jjafferr عاشت ايدك استاذ

وعليكم السلام 🙂 عملتها بطريقة تختلف ، عن طريق التنسيق الشرطي: في النموذج fy اضفت حقل مخفي غير مربوط بمصدر بيانات ، اسميته tmp_yyy وفي التنسيق الشرطي للحقل yyy استعملت : . بينما في النموذج fx ، وعلى حدث الحالي ، ارسل قيمة الحقل الذي انقر عليه ، الى الحقل tmp_yyy في النموذج fy : Private Sub Form_Current() On Error GoTo err_Form_Current Me.Parent!fy!tmp_yyy = Me.xxx Exit_Form_Current: Exit Sub err_Form_Current: If Err.Number = 2455 Then 'could not see othe Form on startup Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub جعفر 1470.fxy.accdb.zip

أخي الكريم ممكن التوضيح : متى يكون الترجيل وعلى أي أساس.

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

There are not enought details but try the following code study it well and change it to suit your needs Option Explicit Private Sub ComboBox1_Change() Dim ws As Worksheet, i As Integer, m As Long, r As Long, k As Long For i = 2 To 5 Set ws = ThisWorkbook.Worksheets(i) With ws m = .Cells(Rows.Count, "D").End(xlUp).Row If m <= 1 Then GoTo NXT For r = 2 To m If .Cells(r, "D").Value = ComboBox1.Value Then With Me.ListBox1 If k = 0 Then .ColumnCount = 3 .AddItem .List(k, 0) = ws.Cells(r, 1).Value .List(k, 1) = ws.Cells(r, 2).Value .List(k, 2) = ws.Cells(r, 6).Value k = k + 1 End With End If Next r NXT: End With Next i End Sub

مشاركة غير مكتملة نهائيا ... لا تنتظر المساعدة من احد بدون رفع ملف مدعوم بشرح كافى عن المطلوب ... وذلك تجنباً لإهدار وقت الأساتذة دون جدوى أو أهمية !!!

يومين ان شاء الله وانزل الموضوع لأن فيه تفاصيل كتير

^_^ هتفضل مشوقنا كده للموضوع 😁

THANK YOU SO MUCH

Sub Test() Const sOut As String = "Output" Dim a(1 To 10000, 1 To 4), ws As Worksheet, sh As Worksheet, m As Long, r As Long, k As Long Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next: Sheets(sOut).Delete: On Error GoTo 0 Application.DisplayAlerts = True For Each ws In ThisWorkbook.Worksheets m = ws.Cells(Rows.Count, "V").End(xlUp).Row For r = 21 To m If Trim(ws.Cells(r, "Q").Value) = "HEALTHY" Then k = k + 1 a(k, 1) = ws.Cells(r, "R").Value a(k, 2) = ws.Cells(r, "P").Value a(k, 3) = ws.Range("C6").Value a(k, 4) = ws.Range("B14").Value End If Next r Next ws If k > 0 Then Sheets.Add , Sheets(Sheets.Count) ActiveSheet.Name = sOut With Sheets(sOut) .Range("A1").Resize(, 4).Value = Array("Names", "Date", "Grade", "Class") .Range("A2").Resize(UBound(a, 1), UBound(a, 2)).Value = a .DisplayRightToLeft = True .Columns.AutoFit End With Else MsgBox "No Data", vbExclamation: Exit Sub End If Application.ScreenUpdating = True End Sub Please learn how to click on the LIKE button

مع ان هذا يُعتبر مخالف لقوانين المنتدى: 21. يُمنع منعا باتا الإجابة على سؤالك أو أي حوار فني على الخاص أو إلى بريدك الخاص، الفائدة يجب أن تعم. ولكننا سننظر له على ان نتائج هذه المساعدة سوف تستفيد منها في تنقيح برنامجك ، وستلخص لنا النتيجة هنا ، حتى يستفيد الجميع من ذلك 🙂 جعفر

In standard module put the code Private Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long Private Play, sMusicFile As String Sub Play_MP3_File() PlaySound ThisWorkbook.Path & "\YOURFILE.mp3" End Sub Public Sub PlaySound(ByVal File$) Dim sPath As String, sFileName As String sMusicFile = File Play = mciSendString("play " & sMusicFile, 0&, 0, 0) If Play <> 0 Then sPath = CurDir If InStr(sMusicFile, ":") > 0 Then ChDrive (Left(sMusicFile, 1)) If InStr(sMusicFile, "\") > 0 Then ChDir (Left(sMusicFile, InStrRev(sMusicFile, "\") - 1)) sFileName = Mid(sMusicFile, InStrRev(sMusicFile, "\") + 1) If InStr(sFileName, " ") > 0 Then FileCopy sFileName, Replace(sFileName, " ", "") sMusicFile = Left(sMusicFile, InStrRev(sMusicFile, "\")) & Replace(sFileName, " ", "") Play = mciSendString("play " & Replace(sFileName, " ", ""), 0&, 0, 0) Else Play = mciSendString("play " & sFileName, 0&, 0, 0) End If Else sFileName = Replace(sMusicFile, " ", "") If sMusicFile <> sFileName Then FileCopy sMusicFile, sFileName: sMusicFile = sFileName Play = mciSendString("play " & sMusicFile, 0&, 0, 0) End If ChDrive (Left(sPath, 1)) ChDir (Left(sPath, InStrRev(sPath, "\") - 1)) End If End Sub Public Sub StopSound(Optional ByVal FullFile$) Play = mciSendString("close " & sMusicFile, 0&, 0, 0) End Sub Then in ThisWorkbook module put the code Private Sub Workbook_Open() Call Play_MP3_File End Sub

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

To implement With your workbook active press Alt+F11 to bring up the vba window In the Visual Basic window use the menu to Insert|Module Copy and Paste the code below into the main right hand pane that opens at step 2 Close the Visual Basic window Press Alt+F8 to bring up the Macro dialog Select the macro & click Run Your workbook will need to be saved as a macro-enabled workbook (*.xlsm)

Suppose the word HEALTHY will be in column Q try the following code Sub Test() Const sOut As String = "Output" Dim a(1 To 10000, 1 To 1), ws As Worksheet, sh As Worksheet, m As Long, r As Long, k As Long Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next: Sheets(sOut).Delete: On Error GoTo 0 Application.DisplayAlerts = True For Each ws In ThisWorkbook.Worksheets m = ws.Cells(Rows.Count, "V").End(xlUp).Row For r = 21 To m If ws.Cells(r, "Q").Value = "HEALTHY" Then k = k + 1 a(k, 1) = ws.Cells(r, "R").Value End If Next r Next ws If k > 0 Then Sheets.Add , Sheets(Sheets.Count) ActiveSheet.Name = sOut With Sheets(sOut) .Range("A1").Value = "Results" .Range("A2").Resize(UBound(a, 1), UBound(a, 2)).Value = a End With Else MsgBox "No Data", vbExclamation: Exit Sub End If Application.ScreenUpdating = True End Sub

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Private Const SW_SHOWMAXIMIZED As Long = 3 Private Const SW_SHOWNORMAL As Long = 1 Sub PlayMusic(strFile As String) If ShellExecute(0&, "Play", strFile, 0&, 0&, SW_SHOWNORMAL) < 33 Then MsgBox "Something Went Wrong", vbInformation End If End Sub Sub Test_PlayMusic() Call PlayMusic(ThisWorkbook.Path & "\YOURFILE.mp3") End Sub

طيب المثال من عندى والشرح من عندك ♥ Menu.mdb

صديقي ... اليك قاعدة البيانات مع التعديل حسب ما طلبت وبطريقة اسهل وبدون اضافة اكواد او موديول . Service.956-Up.accdb

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