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

السلام عليكم ورحمة الله وبركاته يسرني اليوم أن أقدم لكم هذه الهدية المتميزة والرائعة (مكتبة الأكواد الخاصة) :: الإصدار الثالث :: مكتبة عامرة بمئات الأكواد VBA داعمة للمبرمجين وجزء لا يتجزأ من عملهم. تختصر الوقت وتسهل العمل على مصممي البرامج. وهي مكتبة عامة يمكن استخدامها لأي لغات برمجية أخرى . من مميزات المكتبة : - أكثر من 360 كود ودالة في مختلف الفنون والمجالات . - قابلة لحفظ مرفقات مع الكود لدعم التطبيق. - يمكنك إضافة أكوادك الخاصة لتكون مكتبة داعمة لكل مبرمج. - سهلة الاستخدام . تحميل المكتبة : مكتبة الأكواد الخاصة zip.zip ولا تنسوني من صالح دعواتكم 🙂🌹

لم اجد تفاعل أو اى رد يدل على نجاح فاعلية التطبيق والتجربة وهذه القواعد للتجربة تم مراعاة عند كتابة الأكواد العمل على كل من النواتان 32x , 64x استاذى الجليل الاستاذ @Moosak اردت فقط الاطمئنان على المكتبة العامرة Moh3sam.zip

-تجهيز مجلدات وملف الصوت الخطوة الاولى قم بانشاء مجلد جديد فى مسار قاعدة البيانات الحالى باسم ( Resurce ) الخطوة الثانية قم بفتح المجلد السابق وقم بانشاء مجلد جديد بداخله باسم ( Audio Files ) الخطوة الثالثة قم بنسخ ملف صوت الى المجلد ( Audio Files ) اما بامتداد wav , .mp3. --------------------- -تجهيز قاعدة البيانات الخطوة الاولى قم بانشاء وحدة نمطية باسم ( modPlayAudio ) وقم بلصق الاكواد الاتية فى هذه الوحدة النمطية Option Compare Database Option Explicit #If VBA7 And Win64 Then 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 Declare PtrSafe Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long Private Declare PtrSafe Function playSound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long #Else Private Declare 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 Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long Private Declare Function playSound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long #End If Const SND_ALIAS_SYSTEMASTERISK As String = "SystemAsterisk" Const SND_ALIAS_SYSTEMDEFAULT As String = "SystemDefault" Const SND_ALIAS_SYSTEMEXCLAMATION As String = "SystemExclamation" Const SND_ALIAS_SYSTEMEXIT As String = "SystemExit" Const SND_ALIAS_SYSTEMHAND As String = "SystemHand" Const SND_ALIAS_SYSTEMQUESTION As String = "SystemQuestion" Const SND_ALIAS_SYSTEMSTART As String = "SystemStart" Const SND_ALIAS_SYSTEMWELCOME As String = "SystemWelcome" Const SND_ALIAS_YouGotMail As String = "MailBeep" ' playsound Params Const SND_LOOP = &H8 Const SND_ALIAS = &H10000 Const SND_NODEFAULT = &H2 ' silence if no sound associated with event Const SND_ASYNC = &H1 ' play async (don't freeze program while sound is playing) Private sMusicFile As String Public soundOn As Boolean Dim mp3Path As String Dim wavPath As String Dim Play As Variant Public Sub Sound_MP3(ByVal File$) sMusicFile = GetShortPath(File) Play = mciSendString("play " & sMusicFile, 0&, 0, 0) If Play <> 0 Then End If End Sub Public Sub Stop_MP3(Optional ByVal FullFile$) Play = mciSendString("close " & sMusicFile, 0&, 0, 0) End Sub Public Function GetShortPath(ByVal strFileName As String) As String Dim lngRes As Long, strPath As String strPath = String$(165, 0) lngRes = GetShortPathName(strFileName, strPath, 164) GetShortPath = Left$(strPath, lngRes) End Function Function IsFile(ByVal fName As String) As Boolean On Error Resume Next IsFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory) End Function Public Function AudioFilePath() As String AudioFilePath = CurrentProject.Path & "\Resurce\Audio Files\" End Function Public Function PlayFile(ByVal FileName_ As String) Dim Msg As String Msg = ChrW(1578) & ChrW(1571) & ChrW(1603) & ChrW(1583) & ChrW(32) & ChrW(1605) & ChrW(1606) & ChrW(32) & ChrW(1608) & ChrW(1580) & _ ChrW(1608) & ChrW(1583) & ChrW(32) & ChrW(1605) & ChrW(1587) & ChrW(1575) & ChrW(1585) & ChrW(32) & ChrW(40) & ChrW(32) & _ ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(32) & ChrW(47) & ChrW(32) & ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(1575) & _ ChrW(1578) & ChrW(41) & ChrW(32) & ChrW(1575) & ChrW(1604) & ChrW(1589) & ChrW(1608) & ChrW(1578) & ChrW(32) & ChrW(46) & _ ChrW(13) & ChrW(10) & ChrW(1578) & ChrW(1571) & ChrW(1603) & ChrW(1583) & ChrW(32) & ChrW(1605) & ChrW(1606) & ChrW(32) & _ ChrW(1608) & ChrW(1580) & ChrW(1608) & ChrW(1583) & ChrW(32) & ChrW(40) & ChrW(32) & ChrW(1605) & ChrW(1604) & ChrW(1601) & _ ChrW(32) & ChrW(47) & ChrW(32) & ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(1575) & ChrW(1578) & ChrW(41) & ChrW(32) & _ ChrW(1575) & ChrW(1604) & ChrW(1589) & ChrW(1608) & ChrW(1578) & ChrW(32) & ChrW(1601) & ChrW(1609) & ChrW(32) & ChrW(1575) & _ ChrW(1604) & ChrW(1605) & ChrW(1587) & ChrW(1575) & ChrW(1585) & ChrW(32) & ChrW(1575) & ChrW(1604) & ChrW(1605) & _ ChrW(1581) & ChrW(1583) & ChrW(1583) & ChrW(32) & ChrW(46) & ChrW(13) & ChrW(10) & ChrW(1578) & ChrW(1571) & _ ChrW(1603) & ChrW(1583) & ChrW(32) & ChrW(1605) & ChrW(1606) & ChrW(32) & ChrW(1575) & ChrW(1587) & ChrW(1605) & _ ChrW(32) & ChrW(32) & ChrW(40) & ChrW(32) & ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(32) & ChrW(47) & ChrW(32) & _ ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(1575) & ChrW(1578) & ChrW(41) & ChrW(32) & ChrW(1575) & ChrW(1604) & _ ChrW(1589) & ChrW(1608) & ChrW(1578) & ChrW(32) & ChrW(46) mp3Path = AudioFilePath & FileName_ & ".mp3" wavPath = AudioFilePath & FileName_ & ".wav" StopFile If IsFile(mp3Path) Then Sound_MP3 (mp3Path): Exit Function If IsFile(wavPath) Then playSound (wavPath), vbNull, SND_ALIAS Or SND_NODEFAULT Or SND_ASYNC: Exit Function If IsFile(mp3Path) = IsFile(wavPath) Then MsgBox (Msg), vbOKOnly + vbMsgBoxRtlReading + vbMsgBoxRight: Exit Function End Function Public Function StopFile() playSound vbNullString, ByVal 0&, SND_NODEFAULT Stop_MP3 (mp3Path) End Function الخطوة الثانية قم بانشاء نموذج باسم ( frmPlayAudio ) الخطوة الثالثة قم بانشاء مربع نص فى النموذج السابق باسم ( txtAudioFileName ) الخطوة الرابعة قم بانشاء زر أمر فى النموذج السابق باسم ( cmdPlay ) وفى حدث عند النقر ضع الكود الاتى soundOn = True: PlayFile (Me.txtAudioFileName) الخطوة الخامسة قم بانشاء زر أمر فى النموذج السابق باسم ( cmdStop ) وفى حدث عند النقر ضع الكود الاتى StopFile الخطوة السادسة فى حدث عند إغلاق النموذج ضع الكود الاتى StopFile الخطوة السابعة بعد حفظ ما سبق افتح النموذج وادخل فى مربع النص ( txtAudioFileName ) اسم ملف الصوت الموجود فى المسار المحدد بدون الامتداد مثلا لو ملف الصوت باسم : MyAudio.mp3 Or MyAudio.wav اسم ملف الصوت فى مربع النص ( txtAudioFileName ) يكون فى الشكل الاتى فقط : MyAudio والان جرب الضغط على زر الامر الخاص بالتشغيل تارة وزر الامر الخاص بالايقاف تارة أخرى طيب ملاحظة مهمه : الطريقة ودوال API هنا تقوم بتشغيل ملفات صوت من النوعين MP3 . WAV <<---< والله دلع شغل فاخر من الأخر تم صياغة الكود بمرونه مطلقة للتعامل مع الملف بغض النظر عن امتداد الملف اه والله زيمبئولك كده مش مصدق ليه مش بئولك شغل فاخر اللى مش عاجبه المسار لملفات الصوت او عاوز يغير مكانها او اسمها طبعا فى الموديول يغير فى الروتين ده على مزاجه AudioFilePath() انا شرحت بالتفصيل الممل اياك حد يقول لى عاوز مرفق أو مش عارف يطبق الشرح

وحماية ثالثة .. ان يحميك الله من كل سوء ، ويطيل عمرك على طاعته

جزاكم الله خيرا اخى ابو يوسف @محمد حسن المحمد جزاكم الله خيرا اخي @محمد يوسف ابو يوسف جزاكم الله خيرا علي التنبيه وهذا نص تقرير اخى ابو يوسف محمد حسن المحمد جزاه الله خيرا السلام عليكم ورحمة الله وبركاته إخوتي أساتذتي الكرام: تحية طيبة وبعد أرى أن هذا الموضوع وإن كان في ظاهره يخص سؤال أو أكثر في الإكسل،إلا أنه في حقيقة الأمر يفتح باباً واسعاً لما لا يرضي الله وهو ما يخالف برأيي منهجنا كمسلمين فقد ثبت عن النبي ﷺ أنه قال: من اقتبس شعبة من النجوم؛ فقد اقتبس شعبة من السحر، زاد ما زاد فتعلم التنجيم لمعرفة الحوادث، ودعوى علم الغيب هذا منكر عظيم وإنما هي كما قال الله -جل وعلا- زينةٌ للسماء، ورجوم للشياطين، وعلامات يهتدى بها، فمن تعلمها لمعرفة الطرق، وأوقات الحراثة، وأشباه ذلك مما هو معروف؛ فهذا لا بأس به، أما أن يتعلمها لاعتقاد أنه بهذا يعلم الغيب، أو لأنها هي المحدثة للحوادث، فهذا كله خلاف منهجنا وديننا والواجب على المؤمن أن يتقيد بالأمر الشرعي، وأن يحذر ما نهى الله عنه، والله يقول: قُل لَّا يَعْلَمُ مَن فِي السَّمَاوَاتِ وَالْأَرْضِ الْغَيْبَ إِلَّا اللَّهُ فالغيب عنده وهو الذي يعلمه -جل وعلا- وليس عند المنجمين والسحرة والكهنة، ونحو ذلك ممن يدعون علم الغيب. جزاكم الله خيرًا.

السلام عليكم و رحمة الله استخدم هذه المعادلة =INDEX($E$2:$E$11;MATCH(VALUE(LEFT(E2;SEARCH("-";E2)-1));$A$2:$A$11;0))

السلام عليكم خير الكلام ما قل ودل . اللهم صل على محمد وآله وصحبه . بسبب ملاحظتي لحرص البعض _خاصة المستجدين _ على مسألة الحماية واستخدام طرق معقدة والبحث عن الجديد والأقوى احببت ان انشر تجربتي وخبرتي في هذه المسألة كأيسر وكذلك اقوى طريقة . الحماية من جهتين : 1- حماية البيانات وهي الجداول .. وهذه تهم المستخدم ( العميل) 2- حماية البناء ..( التصميم بما يشتمل من اكواد وغيرها ) وهذه تهم المبرمج ----------------------------------- الجهة الأولى : 1- اكسس ضعيف جدا في حماية جداوله .. لأن اي مستخدم مهما ضعفت صلاحياته يمكنه التمكن من الجداول ( نسخ / تغيير / حذف) 2- اي شخص يملك قاعدة بيانات اكسس يمكنه الوصول الى الجداول ما لم يتم حمايتها بكلمة مرور اكسس 3- ينطبق هذا على القواعد المقسمة حيث يجب تفعيل كلمة مرور اكسس على الواجهات الأمامية قبل عرض كلمة مرور المستخدم ، والا ستكون الجداول في متناول اليد . نأتي للجهة الثانية وهي ما يخص المبرمج : من خلال تجارب وخبرة سنوات افضل طريقة تريح المبرمج وكذلك العميل وبعيدا عن غرس الملفات والريجستري والفلاش : الاعتماد على رقم سيريال واحد من عتاد الجهاز ( قرص صلب / معالج / اللوحة الأم ) بشرط ان يكون الرقم اساسي خاصة القرص الصلب لا يتغير عند عمل التهيئة . فكون الرقم اساسي لا يتغير يفيد العميل عندما يقوم بتهيئة القرص ، وهو مريح ايضا للمبرمج ( يوجد كثير من المواضيع هنا في هذا المنتدى تشرح عملية استخلاص ارقام القطع الداخلية لجهاز الحاسب .. ابحث ) الخطوات : --------------------------------- - استخراج واستخلاص الارقام من السيريل ( غالبا يأتي مختلط بارقام وحروف) سيظهر هذا الرقم للعميل في فورم التسجيل واسفله حقل لادخال رقم النسخة ------------------------------- - نعمل دالة1 = استقطاع جزء محدد من النتيجة .. مثلا خمسة ارقام او اربعة ارقام من اليمين او من اليسار ( استقطاع ثابت) - نعمل دالة2 = اجراء معادلة على دالة1 ، مثلا ( دالة1 (x) 1234567 + 53954 ) ------------------------------- - عندما يرسل العميل رقم السيريل ويطلب رقم النسخة نقوم بعمل المعادلة ومن ثم نرسلها للعميل نتيجة هذه المعادلة ستبقى ملك دائم لجهاز حاسب واحد ما دام على قيد الحياة -------------------------------------------------------------------------------------------------------------- ما ذكرته اعلاه هو للنسخة الدائمة .. أما النسخة المؤقته فأقوم بعملها كالتالي : يجب ان يكون العمل مقسم الى واجهات وجداول . يجب ان اتعامل مع العميل على اساس نسختين من الواجهات : مؤقتة / دائمة الفرق بين الواجهة المؤقتة والواجهة الدائمة .. هي زيادة سطرين بشرطين في المؤقتة 1- الشرط 1: لن تفتح المؤقتة الا مع وجود الأنترنت شغال 2- نضع سطرا نحدد تاريخ توقف البرنامج ( يتم جلب التاريخ من الانترنت ) لنفرض انتهت مدة التجربة بعد شهر او شهرين .. وتم الشراء .. هنا نرسل الواجهة الدائمة للصق والاستبدال . هنا نكون حافظنا على بيانات العميل المدخلة وعلى حقوقنا البرمجية ----------------------------------------------------- نقطة اخيرة : سيتبادر الى الذهن ! اين يحفظ رقم النسخة ؟ لأن البرنامج سيطلبه عند كل اقلاع ؟ الجواب : ما دام رقم النسخة ملكا للجهاز فيمكن حفظه في اي مكان ، مثلا في حقل في جدول بشرط ان يحتوي الجدول على سجل واحد فقط او يمكن حفظه في ملف نصي بجانب قاعدة البيانات وهذه الطريقة الاخيرة هي الافضل بل تجب اذا تم توزيع الواجهات على اكثر من جهاز .. والسبب ان كل جهاز سيكون له رقمه الخاص هذا ما لدي آمل تجدوا فائدة

وعليكم السلام أخي الكريم قم بتغيير اسم الملف المسمى بيانات العاملين 21-9-2023 إلى Employees DB أو قم بتغيير الاسم في الكود (كما يحلو لك) ضع الكود التالي في الملف المسمى الإدارة العامة Sub Test() Dim a, wb As Workbook, ws As Worksheet, sh As Worksheet, c As Range, dic As Object, sName As String, lr As Long Application.ScreenUpdating = False Set dic = CreateObject("Scripting.Dictionary") Set wb = Workbooks.Open(ThisWorkbook.Path & "\Employees DB.xls") Set ws = wb.Worksheets(1) Set sh = ThisWorkbook.ActiveSheet For Each c In ws.Range("C6:C" & ws.Cells(Rows.Count, "C").End(xlUp).Row) sName = c.Value If Not dic.Exists(sName) And sName <> Empty Then dic.Add sName, Array(c.Offset(0, 1).Value, c.Offset(0, 2).Value, c.Offset(0, 3).Value) End If Next c wb.Close SaveChanges:=False lr = sh.Cells(Rows.Count, "B").End(xlUp).Row sh.Range("E3:G" & lr).ClearContents For Each c In sh.Range("B3:B" & lr) sName = c.Value If dic.Exists(sName) Then a = dic(sName) c.Offset(, 3).Resize(, 3).Value = a End If Next c Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله وبركاته ضع هذا قبل اخر End If Me.Frame1.Height = Me.Frame1.Height + 14 Me.ListBox2.Height = ListBox2.Height + 14 Me.Label8.Top = Me.Frame1.Top + Me.Frame1.Height + 10: Me.Label9.Top = Me.Label8.Top + Me.Label8.Height: Me.Label10.Top = Me.Label9.Top + Me.Label9.Height Me.TextBox1.Top = Me.Label8.Top: Me.TextBox2.Top = Me.TextBox1.Top + Me.TextBox1.Height: Me.TextBox3.Top = Me.TextBox2.Top + Me.TextBox2.Height Me.CommandButton1.Top = Me.Label8.Top

اذا كنت تقصد اظهار التقويم لاختيار التاريخ عندها يمكن استخدام اداتين date picker او calendar . هذه محاولة بعد القيام بإضافة فورم التقويم والقيام ببعض التعديلات . قم بالنقر مرتين علي خلية التاريخ وسيظهر التقويم . ولكن هذا يتوقف على اصدار الاوفيس اشك انها تعمل مع الإصدارات قبل 2016 واذا واجهتك مشكلة بإظهار رسالة بعدم وجود كائن عنده يجب تنصيبه حتى يظهر لك . حاليا يعمل معي باستخدام بإصدار 2019 تحياتي مطلوب تعديل.xlsm

والله أعلى وأعلم على قدر معلوماتى للاسف PlaySound API الخاصة بتشغيل ملفات صوت ذات الامتداد WAV لا تدعم الإيقاف المؤقت/الاستئناف وننتظر من اساتذتنا أهل الخبرة مراجعتنا فى هذه النقطة إن أمكن وهذا تعديل بسيط علشان خاطر عيونك تدلل PlayAudio V0.2.zip

اذن انت تحتاج - جدول واحد فقط لادخال القوانين فيه حقلان ( رقم المادة - نص المادة ) - نموذج لادخال القوانين للجدول المذكور - نموذج للبحث والطباعة - تقرير لطباعة القانون بعد البحث هذا في رأيي حسب ما ذكرت انت من طلبات ..

جرب الكود التالي عله يفي بالغرض بإذن الله Sub Test() Dim x, ws As Worksheet, lr As Long, i As Long, j As Long, startSeq As Long, endSeq As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) lr = ws.Cells(ws.Rows.Count, "L").End(xlUp).Row ws.Range("A2:A" & lr).ClearContents For i = 2 To lr j = 0 x = Application.Match(ws.Cells(i, "L").Value, ws.Columns("T"), 0) If Not IsError(x) Then startSeq = ws.Cells(x, "U").Value endSeq = ws.Cells(x, "V").Value Do j = j + 1 ws.Cells(i + j - 1, "A").Value = startSeq If startSeq > endSeq Then ws.Cells(i + j - 1, "A").Value = Empty startSeq = startSeq + 1 Loop Until ws.Cells(i, "L").Value <> ws.Cells(i + j, "L").Value i = i + j - 1 End If Next i Application.ScreenUpdating = True End Sub إذا قمت بحذف صفوف من البيانات سيلزمك تنفيذ الكود من جديد لضبط التسلسل

وعليكم السلام ورحمة الله تعالى وبركاته اليوزرفورم ينقصه عدة اكواد كالتعديل والحدف وبما انك طلبت تصحيح الاكواد الموجودة فقط قم بافراغ اليوزرفورم من الاكواد السابقة وقم بنسخ الاكواد التالية Private Sub CommandButton3_Click() ' بحث Dim sh1 As Worksheet Dim f As Range Set sh1 = Sheet54 lrw = sh1.Cells(Rows.Count, 5).End(xlUp).Row With TextBox11 If .Value = "" Then MsgBox "من فضلك ادخل الاسم الذي تريد البحث عنه يا عم سعد", vbCritical, "تنبيه يا عم سعد": Exit Sub Set f = sh1.Range("E5:E" & lrw).Find(TextBox11.Value, , xlValues, xlWhole, , , False) If Not f Is Nothing Then TextBox1.Value = sh1.Range("C" & f.Row).Value TextBox2.Value = sh1.Range("D" & f.Row).Value TextBox3.Value = sh1.Range("E" & f.Row).Value TextBox4.Value = sh1.Range("F" & f.Row).Value TextBox5.Value = sh1.Range("G" & f.Row).Value TextBox6.Value = sh1.Range("H" & f.Row).Value TextBox7.Value = sh1.Range("I" & f.Row).Value TextBox8.Value = sh1.Range("J" & f.Row).Value TextBox9.Value = sh1.Range("K" & f.Row).Value TextBox10.Value = sh1.Range("L" & f.Row).Value openpic = sh1.Range("M" & f.Row).Value Me.Image1.Picture = LoadPicture(openpic) Me.Image1.Visible = True Else MsgBox "الاسم غير موجود" End If End With End Sub '''''''''''''''''''''''''' Private Sub CommandButton2_Click() ' اظافة Dim ws As Worksheet: Set ws = Sheet54 Dim lastrow As Long lastrow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1 With ws ligne = .Cells(.Rows.Count, "C").End(xlUp).Row + 1 End With ws.Cells(ligne, 4) = Me.TextBox2.Text ws.Cells(ligne, 5) = Me.TextBox3.Text ws.Cells(ligne, 6) = Me.TextBox4.Text ws.Cells(ligne, 7) = Me.TextBox5.Text ws.Cells(ligne, 8) = Me.TextBox6.Text ws.Cells(ligne, 9) = Me.TextBox7.Text ws.Cells(ligne, 10) = Me.TextBox8.Text ws.Cells(ligne, 11) = Me.TextBox9.Text ws.Cells(ligne, 12) = Me.TextBox10.Text ws.Range("C10").Value = 1 With ws.Range("C10:C" & lastrow) .Formula = "=Row() - 9" .Value = .Value End With For I = 1 To 11 Me("Textbox" & I) = "" Next I MsgBox "تم حفظ البيانات بنجاح يا عم سعد", vbInformation, "تنبيه يا عم سعد" End Sub ''''''''''''''''''''''''''''''''''''' Private Sub ListBox1_Click() Me.TextBox11.Value = Me.ListBox1.Column(0) Me.ListBox1.Visible = False End Sub Private Sub TextBox11_Change() 'الى الليست بوكس' جلب جملة البحث If Me.TextBox11.Text = "" Then Me.ListBox1.Visible = False Else Me.ListBox1.Visible = True Me.ListBox1.Clear '------------------------------ Dim lrw Set W = Sheet54 lrw = W.Cells(Rows.Count, 5).End(xlUp).Row l = 0 For Each c In Range("e10:e" & lrw) If c Like TextBox11.Text & "*" Then ListBox1.AddItem ListBox1.List(l, 0) = Cells(c.Row, 5).Value l = l + 1 End If Next c End If End Sub Private Sub TextBox11_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If Not iGblInhibitTextBoxEvents Then TextBox11.Value = "" End If End Sub محمد (2).xlsm

السلام عليكم ومشاركة مع استاذى ومعلمى @دروب مبرمج لانى كنت أفكر فى الحل بأبسط الطرق قمت باستخدام دوال تحويل البيانات لان الحقل المراد التعامل معه حقل نصى ولاننا مستقبلا نريد التعامل مع القيم الرقمية داخل الحقل النصى Sales قمت بعمل استعلام بسيط لتحويل نوع البيانات من نصية الى رقمية من خلال الدالة CLng([sales]) فيكون بناء الاستعلام كالاتى SELECT sales.dname, CLng([sales]) AS FldSales FROM sales; الخطوة الثانية : بعد ذلك الان سوف اتعامل مع هذا الاستعلام وليس الجدول ووضع الكود الاتى على زر الامر على الترتيب الاتى Dim strSQL As String الاعلان عن متغير نصى If IsNull(txtXTop) Or Len(txtXTop) = 0 Then اى ان كان مربع النص txtXTop طول السلسلة النصيه له = 0 اى انه فارغ بدون اى قيم فى هذه الحالة سوف اقوم باسناد جملة الاستعلام البسيط مصدر البيانات الان الى المتغير النصى strSQL strSQL = "SELECT sales.dname, CLng([sales]) AS FldSales FROM sales" اما اذا كان مربع النص txtXTop طول السلسلة النصيه له > 0 اى انه يحتوى على قيم قى هذه الحالة سوف اقوم باسناد جملة الاستعلام الاتية الى المتغير ولكن لان جملة الاستعلام عبارة عن سلسلة نصية سوف اقوم باستخدام دوال تحويل البيانات مرة أخرى ولكن فى هذه المرة اريد تحويل الرقم من مربع النص الى سلسلة نصية لان مربع النص الان هو المتغير الذى يمرر قيمة ال Top لاستكمال صياغة جملة SQL دوى ادنى مشاكل من خلال CStr(txtXTop) قتكون الجملة التى سوق يتم اسنادها بهذا الشكل "SELECT TOP " & CStr(txtXTop) & " * FROM qryData ORDER BY FldSales DESC;" وكانت فكرتى تتمحور حول جعل النموذج يعرض البيانات لذلك سوف اسند الى مصدر بيانات النموذج جملة الاستعلام تبعا للحالة من خلال المتغير Me.RecordSource = strSQL وتم اضافة كود تصيد الاخطاء فى حالة تم استخدام اى شئ يخالف الارقام فى مربع النص على النموذج اعتذر للاطالة واعتذر مسبقا فى جالة وجود اى قصور بسبب محاولتى للابقاء على التصميم دون المساس او التغيير فيه مع محاولة الوصول للنتيجة بأبسط طريق واخيرا المرفق select ( X ) Top.accdb

جرب هذه المعادلة =IF(M4*0.0199<1.99,1.99,IF(M4*0.0199>=0.299*F4,0.299*F4,M4*0.0199)) على اعتبار أن قيمة الصفقة هي الخلية F4 بالتوفيق

يمكنك تجربة هذه المحاولة بالمعادلات بدلا من تصدير النتائج في شيت جديد يمكنك كتابة مصطلح البحث والحصول على النتائج في شيت النتائج أهم شيء معادلة المسلسل في شيت البيانات data لأن معادلة البحث vlookup تعتمد عليها بالتوفيق فلترة نتائج البحث في شيت جديد.xls

عليكم السلام عسى غياب يومية.xlsm

السلام عليكم و رحمة الله استخدم هذا الكود Sub Get_AbsDay() Dim ws As Worksheet, LR As Long Dim I As Long, C As Range, x As Integer Dim A As String, B As String, Kod As String Dim p As Integer, q As Integer Set ws = Sheets("Sheet1") ws.Range("R8:U8") = "" ws.Range("R10:U10") = "" '--------------------- LR = ws.Range("B" & Rows.Count).End(3).Row Kod = ws.Range("N6").Value p = 17 q = 17 A = "أ" B = "غ" I = 2 Do While I <= LR If ws.Cells(I, 1) = Kod Then ws.Range("N8").Value = ws.Cells(I, 2).Value x = ws.Cells(I, 1).Row For Each C In ws.Range(ws.Cells(x, 3), ws.Cells(x, 10)) If C.Value = A Then p = p + 1 ws.Cells(8, p).Value = ws.Cells(2, C.Column).Value ElseIf C.Value = B Then q = q + 1 ws.Cells(10, q).Value = ws.Cells(2, C.Column).Value End If Next End If I = I + 1 Loop End Sub

عليكم السلام ورحمة الله وبركاته يمكنك استعمال هذه المعادلة في L6 =IF(H6>0,VLOOKUP(C6,$T$5:$AI$100,MATCH(B6,$T$5:$AI$5,0),0),0) وهذه المعادلة في N6 =IF(AND(H6>0,OR(S6="ض نقل",S6="نقل")),VLOOKUP(C6,$T$5:$AI$100,MATCH(B6,$T$5:$AI$5,0)+1,0),0) لاحظ استعمال match لجلب ؤقم العمود بدلالة رقم أمر التوريد بالتوفيق

وعليكم السلام ورحمة الله وبركاته تفضل اخى جرب الملف الكود فى حدث الشيت Change Private Sub Worksheet_Change(ByVal Target As Range) Dim filterRange As Range Dim dataRange As Range Dim lastRow As Long Dim lastRow2 As Long Application.ScreenUpdating = False If Target.Address = "$P$4" Then lastRow2 = Cells(Rows.Count, "P").End(xlUp).Row Range("P6:V" & lastRow2 + 1).ClearContents If Not IsEmpty(Target.Value) Then lastRow = Cells(Rows.Count, "E").End(xlUp).Row Set dataRange = Range("A6:G" & lastRow) dataRange.AutoFilter Field:=5, Criteria1:="*" & Target.Value & "*" dataRange.Copy Range("P6") dataRange.AutoFilter End If End If Application.ScreenUpdating = True End Sub Data.xlsm

السلام عليكم بها نبدأ أى مشاركة -بما انك لم تقم برفع ملف -فيمكنك استخدام هذا الكود لطلبك: Sub ColorCompanyDuplicates() Dim xRg As Range Dim xTxt As String Dim xCell As Range Dim xChar As String Dim xCellPre As Range Dim xCIndex As Long Dim xCol As Collection Dim i As Long On Error Resume Next If ActiveWindow.RangeSelection.Count > 1 Then xTxt = ActiveWindow.RangeSelection.AddressLocal Else xTxt = ActiveSheet.UsedRange.AddressLocal End If Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8) If xRg Is Nothing Then Exit Sub xCIndex = 2 Set xCol = New Collection For Each xCell In xRg On Error Resume Next If xCell.Value <> "" Then xCol.Add xCell, xCell.Text If Err.Number = 457 Then xCIndex = xCIndex + 1 Set xCellPre = xCol(xCell.Text) If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex ElseIf Err.Number = 9 Then MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel" Exit Sub End If On Error GoTo 0 End If Next End Sub

بعد اذان الاستاذ الفاضل محمد هشام تعديل بدون اضافة عمود جديد للجهة المستلمة وانما لاخذ قيمتها من الخلية L2 من كل شيت والكود بصراحه قمة الروعة والفكر تسلم ايدك وافكارك استاذنا تجميع V2 -2.xlsm

وهذا حل اخر ولكن باستخدام VBA لعمل المطلوب كما تريده وبشكل افضل وتلوين كود الصنف الجديد فى العمود 2 واظهار الاصناف الجديدة فى العمود 3 معا بدون خلايا فارغة استخراج اكواد الاصناف الجديدة وتلوينها VBA .xlsm

تفضل اخى جرب الملف والمعادلة مع مراجعة النتائج للتأكد اما بالنسبة لتلوين الاكود الجديد فى العمود 2 يمكنك استخدام (Conditional Formatting) حذف متكرر ونلوينه.xlsx

جرب هذا الكود SaveNew.xlsm

وعليكم السلام أخي الكريم هذا الملف بعد التعديل فيه تم وضع كود لطباعة صفحة بذاتها ، وكود آخر لطباعة صفحات من رقم .... (الخلية O2)إلى رقم.....(الخلية P2) أما إذا أردت طباعة كل القائمة فامسح الخليتين المذكورتين أعلاه. وستتم طباعة كل الصفحات حسب معادلتين وضعتا في O1 & P1 اعتماداً على الخلية N5 في كل ماسبق بالتوفيق إن شاء الله والسلام عليكم ملاحظة: هذا الكود لأحد الأساتذة الفضلاء - وفقهم الله- آمين كود.xls

تفضل أخي حسب مافهمت تقرير للكل وتفرير للرقم المختار ووافني بالرد test-1.rar

اتفضل ده مثال من أستاذى @دروب مبرمج Replace.accdb

وهذ الكود ان شاء الله يفى بالغرض كما هو المطلوب Public Function MultiReplacements(Optional ByVal strInput As String = "") As String If Nz(strInput, "") = "" Then Exit Function strInput = Replace(strInput, "ي ", "ى " & "") strInput = Left(strInput, Len(strInput) - 1) + Replace(Right(strInput, 1), "ي", "ى") strInput = Replace(strInput, "ة", "ه" & "") strInput = Replace(strInput, "عبدال", "عبد ال" & "") strInput = Replace(strInput, "عبدرب", "عبد رب" & "") MultiReplacements = strInput End Function وطبعا لتجنب حدوث اى مشاكل بسبب استخدام الاحرف العربية داخل محرر الاكواد افضل استخدام الكود الاتى Public Function MultiReplacements(Optional ByVal strInput As String = "") As String If Nz(strInput, "") = "" Then Exit Function strInput = Replace(strInput, ChrW(1610) & ChrW(32), ChrW(1609) & ChrW(32) & "") strInput = Left(strInput, Len(strInput) - 1) + Replace(Right(strInput, 1), ChrW(1610), ChrW(1609)) strInput = Replace(strInput, ChrW(1577), ChrW(1607) & "") strInput = Replace(strInput, ChrW(1593) & ChrW(1576) & ChrW(1583) & ChrW(1575) & ChrW(1604), ChrW(1593) & ChrW(1576) & ChrW(1583) & ChrW(32) & ChrW(1575) & ChrW(1604) & "") strInput = Replace(strInput, ChrW(1593) & ChrW(1576) & ChrW(1583) & ChrW(1585) & ChrW(1576), ChrW(1593) & ChrW(1576) & ChrW(1583) & ChrW(32) & ChrW(1585) & ChrW(1576) & "") MultiReplacements = strInput End Function

تفضل اخى الفاضل ياسر جرب الملف Example (1).xlsm

ادرج ptrsafe ليصبح Declare PtrSafe Function apisndPlaySound Lib "winmm" Alias "sndPlaySoundA" (ByVal filename As String, ByVal snd_async As Long) As Long

عليكم السلام جرب استخدام هذا الكود بعد تحديد الخلايا التي يراد وضع ارتباط تشعبي لها Sub AddHypaerlinks() Dim cl As Range Dim myPath As String, fileName As String myPath = "C:\Users\civat\Desktop\New folder\" 'SET TO WHERE THE FILES ARE LOCATED For Each cl In Selection If Len(cl) > 0 Then fileName = myPath & cl.Value & "*.docx" 'IF THE FILE EXISTS THEN If Len(Dir(fileName)) <> 0 Then ActiveSheet.Hyperlinks.Add cl, myPath & Dir(fileName) End If Next End Sub بالتوفيق

عليكم السلام يمكنك وضع هذه المعادلة في الخلية F3 =(SUM(B3,E3)-SUM(A3,D3))*24 بالتوفيق

تفضل هذا الملف .على الرغم ان كان عليك من البداية رفع ملف بالمشاركة فلا تعنى أى مشاركة شيء بدون ملف يدعمها Colored.xlsb

تفضل <><><><><><> 01.accdb

السلام عليكم ورحمة الله وبركاته 🌹 درسنا اليوم عن طريقة عمل قوائم ديناميكية متحركة بأقل عدد من الأكواد وطريقة مبتكرة . 🙂 النتيجة النهائية : الشرح : تحميل الملف : Dynamic Menus.accdb

مشكور أخي ياسر على كلماتك الطيبة ودعواتك الطيبة والحمد لله الذي بنعمته تتم الصالحات الكود ليس له علاقة بالرسالة .. يمكنك حل المشكلة بالشكل التالي

جرب هذه الكود التالى لعله يكون المطلوب Attendance Report Work Sheet.xlsm

الاوفيس الذي قمت بتنصيبه ٦٤ بت قم بحذفه وتنصيب اوفيس ٣٢ بت ليتوافق مع ملفك

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

كتعديل في كود الفلتر وعدم الحاجة لكود إلغاء الفلتر يمكن استعمال هذا الكود في حدث تغيير محتوى الخلايا في الشيت Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$D$8" Then Dim LastRow As Long Dim FilterRange As Range LastRow = Me.Cells(Rows.Count, "D").End(xlUp).Row Set FilterRange = Range("C9:U" & LastRow) If Not IsEmpty(Range("D8")) Then FilterRange.AutoFilter Field:=2, Criteria1:=Range("D8").Value Else FilterRange.AutoFilter Field:=2 End If End If End Sub بالتوفيق

وعليكم السلام تفضل اخى جرب الملف التالى FilterData.xlsm

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

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

وعليكم السلام ورخمه الله لحذف خلايا محددة في أعمدة معينة في Excel، يمكنك استخدام الكود التالي: Sub DeleteCells() Dim rng As Range Dim cell As Range ' تعيين نطاق الخلايا التي ترغب في حذفها Set rng = Range("A1:A10") ' قم بتغيير "A1:A10" إلى نطاق الخلايا الذي ترغب في حذفه ' حلقة عبر كل خلية في النطاق المحدد For Each cell In rng cell.ClearContents ' حذف محتوى الخلية Next cell End Sub

تفضل جرب تجميع -5.xlsm

@2saad هل ممكن ان تقول لي المتغير i فيما يستخدم بناء على كودك؟!!! Private Sub CommandButton2_Click() Dim add As Integer i = Application.WorksheetFunction.CountA(Sheet54.Range("c:c")) add = Sheet54.Range("c1000").End(xlUp).row + 1 Sheet54.Cells(add, 3).Value = Me.TextBox1.Value Sheet54.Cells(add, 4).Value = Me.TextBox2.Value Sheet54.Cells(add, 5).Value = Me.TextBox3.Value Sheet54.Cells(add, 6).Value = Me.TextBox4.Value Sheet54.Cells(add, 7).Value = Me.TextBox5.Value Sheet54.Cells(add, 8).Value = Me.TextBox6.Value Sheet54.Cells(add, 9).Value = Me.TextBox7.Value Sheet54.Cells(add, 10).Value = Me.TextBox8.Value Sheet54.Cells(add, 11).Value = Me.TextBox9.Value Sheet54.Cells(add, 12).Value = Me.TextBox10.Value Me.TextBox1.Value = "" Me.TextBox2.Value = "" Me.TextBox3.Value = "" Me.TextBox4.Value = "" Me.TextBox5.Value = "" Me.TextBox6.Value = "" Me.TextBox7.Value = "" Me.TextBox8.Value = "" Me.TextBox9.Value = "" Me.TextBox10.Value = "" MsgBox "تم حفظ البيانات بنجاح يا عم سعد", vbInformation, "تنبيه يا عم سعد" End Sub جرب هذا التغيير ولكن قبل كل شيء اتبع الخطوات بعناية 1- احدف اي صف فارغ في الجدول ( لا تجعل الجدول يحتوي على صفوف فارغة) 2- لا داعي للتيكست بوكس الخاص بالتسلسل لانه الكود سيقوم بادراج صف ويقوم بترقيمها اتوماتيكيا حينها سيصبح عند 9 تيكست بوكس وليس 10 كما في الكود 3- تم التعديل باضافة اجراءات خاصة بكائن الجدول هذه محاولة قد تفيدك Private Sub CommandButton2_Click() Dim tbl As ListObject Dim LastRow As Long Set tbl = Sheet54.ListObjects("Table14") LastRow = tbl.Range.Rows.Count With Sheet54 tbl.Range(LastRow, "B").Offset(1) = TextBox1.Value tbl.Range(LastRow, "C").Offset(1) = TextBox2.Value tbl.Range(LastRow, "D").Offset(1) = TextBox3.Value tbl.Range(LastRow, "E").Offset(1) = TextBox4.Value tbl.Range(LastRow, "F").Offset(1) = TextBox5.Value tbl.Range(LastRow, "G").Offset(1) = TextBox6.Value tbl.Range(LastRow, "H").Offset(1) = TextBox7.Value tbl.Range(LastRow, "I").Offset(1) = TextBox8.Value tbl.Range(LastRow, "J").Offset(1) = TextBox9.Value End With MsgBox "تم حفظ البيانات بنجاح يا عم سعد", vbInformation, "تنبيه يا عم سعد" Me.TextBox1.Value = "" Me.TextBox2.Value = "" Me.TextBox3.Value = "" Me.TextBox4.Value = "" Me.TextBox5.Value = "" Me.TextBox6.Value = "" Me.TextBox7.Value = "" Me.TextBox8.Value = "" Me.TextBox9.Value = "" End Sub

إن شاء الله تفيدك معادلات البحث والاقتصاص هذه مع ضرورة ثبات قالب الرسائل على هذه الصيغة بالتوفيق رسائل كاش.xlsx

بارك الله فيكم جميعا جميل جدا هذا العمل إبداع وهذه مساهمتي للبحث في موضوعات منتدى الاكسس ولكن في مجال الويب حتى يمكن البحث بسرعة بمجرد الكتابة ولو في الموبايل بدون الحاجة إلى برنامج الأوفيس https://officena.net/team/mas/access.html بالتوفيق للجميع دعواتكم