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

-تجهيز مجلدات وملف الصوت الخطوة الاولى قم بانشاء مجلد جديد فى مسار قاعدة البيانات الحالى باسم ( 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() انا شرحت بالتفصيل الممل اياك حد يقول لى عاوز مرفق أو مش عارف يطبق الشرح

وعليكم السلام ورحمة الله تعالى وبركاته اليك الملف بعد التعديل على كود الاستاد @حسونة حسين واظافة جميع الاكواد الازمة محمد 4.xlsm

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

اتفضل اداة تساعدك مستقبلا من تصميم الاستاذ القدير @Moosak اتفضل شوف الدرس ده ان اردت الشرح والايضاح

السلام عليكم ورحمة ورحمة الله كان هذا طلبك وتم الاجابة عليه باكثر من طريقة من الاخوة الافاضل انتهى من التصميم ثم فكر فى الحل قم بتغيير التالى x = Columns(1).Cells.Find(Range("N6"), , , 1).Row هنا هتغير حاجتين رقم العمود حيث كان العمود a وهو رقم 1 بالعمود الذى يحتوى على اكواد الموظفين وكمان هتغيير الخلية n6 وهى التى تحتوى على رقم كود الموظف بالخلية الجديدة التى تحتوى على كود الموظف Range("N8") = Cells(x, 2) هنا هتغير حاجتين Range("N8") بالخلية الجديدة التى اصبحت تحتوى على اسم الموظف وكمان هتغير Cells(x, 2) رقم 2 برقم العمود الذى اصبح يحتوى على اسماء الموظفين حسث كان سابقا هو العمود b اى رقم 2 Set r = Cells(x, 1 + Split(Range("N4").Text, "-")(0) * 1).Resize(, 1 + Split(Range("P4").Text, "-")(0) * 1) هنا هتغير Range("N4") باسم الخلية التى تحتوى على تاريخ البداية باسم الخلية الجديدة وكمان هتغيير Range("P4") تاريخ النهاية باسم الخلية الجديدة لتاريخ النهاية واكمل باقى باقى التغييرات بنفس النمط او قم برفع ملف لعمل التعديلات المطلوبة مفيش حد هيكتب توقعات على اساس التعديل الذى قمت به تقبل تحياتى

السلام عليكم وبها نبدأ تفضل كود التعديل Private Sub CommandButton4_Click() Dim SH As Worksheet, X, I As Long Set SH = ThisWorkbook.Worksheets("كي جي1") If TextBox1.Value = "" Then MsgBox "من فضلك ادخل الاسم الذي تريد البحث عنه يا عم سعد", vbCritical, "تنبيه يا عم سعد": Exit Sub X = Application.Match(Val(TextBox1.Value), SH.Columns("C"), 0) If Not IsError(X) Then For I = 1 To 10 SH.Cells(X, I + 2).Value = Controls("TextBox" & I).Value Next I SH.Range("M" & X).Value = openpic Else MsgBox "الاسم غير موجود" End If End Sub

وعليكم السلام ورحمة الله وبركاته حبا وتقديرا للاستاذ الفاضل @ياسر خليل أبو البراء تفضل مواقيت الصلاة.xlsb

من الواضح أن إجراء التمكين غير موجود والذي يسمى enableply لذلك يمكنك استعمال هذين الاجرائين للتعطيل Private Sub Workbook_Open() Application.CommandBars("Ply").Enabled = False End Sub للتمكين Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.CommandBars("Ply").Enabled = True End Sub بالتوفيق

يمكنك استعمال هذه المعادلة في B3 =WORKDAY.INTL(A3-1,D3,16) بالتوفيق

وعليكم السلام إليك هذه المحاولة New Microsoft Excel Worksheet.xlsx

اهلا بك فى المنتدى , يمكنك هذا بالدالة المعرفة ConvertDate ... بوضع هذه المعادلة بالخلية D5 سحباً للأسفل وهذا هو كود الدالة Option Explicit Function ConvertDate(ByRef StringIn As String) As String Dim savedCal As Integer Dim d As Date Dim s As String savedCal = Calendar Calendar = 1 d = CDate(StringIn) Calendar = 0 s = CStr(d) ConvertDate = Format(s, "dd/mm/yyyy") Calendar = savedCal End Function المصنف1.xlsm

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

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

Dim frm As Form Dim intScreenWidth As Integer Dim intScreenHeight As Integer Dim intFormWidth As Integer Dim intFormHeight As Integer Dim intLeft As Integer Dim intTop As Integer ' احضار مرجع للنموذج الحالي Set frm = Screen.ActiveForm ' الحصول على عرض الشاشة وارتفاعها intScreenWidth = Screen.Width / Screen.twipsPerPixelX intScreenHeight = Screen.Height / Screen.TwipsPerPixelY ' الحصول على عرض وارتفاع النموذج intFormWidth = frm.Width / frm.ScaleX intFormHeight = frm.Height / frm.ScaleY ' حساب الموضع الأفقي المتوسط intLeft = (intScreenWidth - intFormWidth) / 2 ' حساب الموضع الرأسي المتوسط intTop = (intScreenHeight - intFormHeight) / 2 ' تعيين الموضع الجديد للنموذج frm.Move intLeft * frm.ScaleX, intTop * frm.ScaleY

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

يجدر القيام بحلقة تكرارية في هذه الحالة Sub delete_tools() Dim ws As Worksheet For Each ws In Worksheets ws.DrawingObjects.Delete Next ws End Sub

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

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

وعليكم السلام هل الاسم في حقل واحد ام الاسم نجزأ بمعنى اسم الابن في حقل والاب في حقل وهكذا....

هذه المشكلة تحصل بسبب اختلاف نسخ الأوفيس بين الأجهزة .. الحل : إفتح ملف أكسس جديد فاضي .. ثم صدر جميع عناصر البرنامج لملف الأكسس الجديد .. وستعمل معك بإذن الله 🙂

شكرا جدا للافاده

وعليكم السلام ورحمة الله وبركاته اضرب فى الاكسل واعرضهم فى ListBox

السلام عليكم ورحمة الله ممكن ارفاق ملف ليتم عمل اللازم

بارك الله فيكم

السلام عليكم نظرا لبعض طلبات الاعضاء الكرام . خاصة ممن يقومون بعمل برامج من أجل كسب العيش أعانهم الله فيما يخص حماية الاكواد التي بملفاتهم لانه عادة ما تحصل سرقة لبرامجهم و هذا بسبب ان أكسل لا يوفر الخماية الكاملة اضافة الى أن هناك برامج تقوم بكشف كلمات سر الملف ببساطة. لذلك اردت أن أقدم فكرة و هي تحويل الكود البرمجي الى ملف DLL مما يوفر حماية قوية للملف عن طريق برنامج vbacompiler for excel و لكن للاسف غير مجاني و هو برنامج يقوم بتحويل الاكواد بالملف الى ملف DLL و تغيير الاكواد بالملف لتستدعى ملف DLL الذي تم انشاؤه و يعمل الملف بكفاءءة عالية لقد قمت بالتجريب و فعلا نتيجة رائعة. يمكنك تحميل البرنامج كنسخة تجريبية . و بالنسبة للذين يعملون البرامج و يبيعونها و يكسبون العيش مننها يمكنهم شراء النسخة الكاملة كيف تحمي ملفك ؟ يمكنك وضع كود خاص بكلمة السر و السريال نمبر للهارد ديسك و ييمكنك وضع الكود التالي عند فتح الملف WORK BOOK OPEN يعني اذاكان رقم السريال نمبر هو مثلا : FFFFF-FFFFF-FFFFF ادخل الرقم السري 222222 و اذا كان خطأا اغلق الملف Private Sub Workbook_Open() Dim RAD As String If CreateObject("Scripting.FileSystemObject").GetDrive("C:\").SerialNumber = "FFFFF-FFFFF-FFFFF" Then RAD = InputBox("Enter password:") If LCaseRAD <> "222222" Then ActiveWorkbook.Close False End If End Sub و بعد الانتهاء من عمل ملف افتح برنامج vbacompiler for excel و جول ملفك الى ملف جديد معه ملف DLL يمكنك التجريب على أي ملف لقد قمت بتجريب البرنامج على ملف أحد الاعضاء و النتيجة بالمرفقات الملف عبارة عن كود بسيط يبحث عن تكرار في عمودين و نقل المكرر الى عمود ثالث هدا الكود مثلا قبل استعمال برنامج vbacompiler for excel Sub brg() ScreenUpdating = False Dim lr As Integer Dim lr1 As Integer Dim c As Range lr1 = ActiveSheet.Range("g" & Rows.Count).End(xlUp).Row For Each c In ActiveSheet.Range("c2:c1000") lr = ActiveSheet.Range("i" & Rows.Count).End(xlUp).Row If WorksheetFunction.CountIf(ActiveSheet.Range("g2:g" & lr1), c.Value) >= 1 Then Cells(lr + 1, 9) = c.Value On Error Resume Next End If Next ScreenUpdating = True End Sub و هذا بعد استعمال البرنامج #If Win64 Then Private Declare PtrSafe Sub p0iflwmc269 Lib "EXEMPLE_xlsm_64.dll" Alias "r8rfyae98n05rlq" () #Else Private Declare Sub p0iflwmc269 Lib "EXEMPLE_xlsm_64.dll" Alias "r8rfyae98n05rlq@0" () #End If Sub brg() p0iflwmc269 End Sub Option Private Module #If Win64 Then Private Declare PtrSafe Function SetThisWbk Lib "EXEMPLE_xlsm_64.dll" Alias "SetThisWorkbook" (ByVal twbk As Object) As Long Private Declare PtrSafe Function u6hpyov9dx5 Lib "EXEMPLE_xlsm_64.dll" (ByVal i As Long, ByVal obj As Object) As Long Private Declare PtrSafe Function c1smc91ey1mls Lib "EXEMPLE_xlsm_64.dll" (ByVal i As Long, ByVal mp As LongPtr) As Long Private Declare PtrSafe Function s1a3nzo1yqora3l Lib "EXEMPLE_xlsm_64.dll" () As Variant Private Declare PtrSafe Sub d0np2x0oglsn Lib "EXEMPLE_xlsm_64.dll" (ByVal dst As Any, ByVal src As LongPtr, ByVal sz As Long) Private Declare PtrSafe Function p8t9c8qi9tgx Lib "EXEMPLE_xlsm_64.dll" (ByRef p() As Any) As LongPtr Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal libFileName As String) As LongPtr Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As LongLong Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr #Else Private Declare Function SetThisWbk Lib "EXEMPLE_xlsm_64.dll" Alias "SetThisWorkbook@4" (ByVal twbk As Object) As Long Private Declare Function u6hpyov9dx5 Lib "EXEMPLE_xlsm_64.dll" Alias "u6hpyov9dx5@8" (ByVal i As Long,ByVal obj As Object) As Long Private Declare Function c1smc91ey1mls Lib "EXEMPLE_xlsm_64.dll" Alias "c1smc91ey1mls@8" (ByVal i As Long,ByVal mp As Long) As Long Private Declare Function s1a3nzo1yqora3l Lib "EXEMPLE_xlsm_64.dll" Alias "s1a3nzo1yqora3l@0" () As Variant Private Declare Sub d0np2x0oglsn Lib "EXEMPLE_xlsm_64.dll" Alias "d0np2x0oglsn@12" (ByVal dst As Any,ByVal src As Long,ByVal sz As Long) Private Declare Function p8t9c8qi9tgx Lib "EXEMPLE_xlsm_64.dll" Alias "p8t9c8qi9tgx@4" (ByRef p() As Any) As Long Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal libFileName As String) As Long Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long #End If Private Function k7wgf46mba0cj8() As String On Error Resume Next k7wgf46mba0cj8 = ThisWorkbook.Path + "\EXEMPLE_xlsm_64.dll" End Function Public Sub p8oi75y3jrid8() #If Win64 Then Dim hModule As LongPtr Dim dllPath As String Dim msg As String On Error Resume Next dllPath = k7wgf46mba0cj8() hModule = LoadLibrary(dllPath) If hModule = 0 Then MsgBox "Cannot load '" & dllPath & "'" ThisWorkbook.Close False Else c1smc91ey1mls 1&, AddressOf u4fw2npwzdn25f4 If SetThisWbk(ThisWorkbook) Then u6hpyov9dx5 3&, Sheet1 u6hpyov9dx5 4&, Sheet2 u6hpyov9dx5 2&, ThisWorkbook ThisWorkbook.Saved = True Else GoTo qpnt End If End If #Else MsgBox "This workbook can work with 64 bit Excel only" ThisWorkbook.Close False #End If Exit Sub qpnt: ThisWorkbook.Close False End Sub Public Sub x1u5slqd9g() On Error GoTo errh SetThisWbk (ThisWorkbook) Exit Sub errh: p8oi75y3jrid8 End Sub Public Function q7uobay8mw() As Boolean On Error Resume Next q7uobay8mw = GetModuleHandle("EXEMPLE_xlsm_64.dll") <> 0& End Function #If Win64 Then Public Function FreeCompiledDll() As LongLong Dim i As Long Do FreeCompiledDll = FreeLibrary(GetModuleHandle("EXEMPLE_xlsm_64.dll")) i = i + 1 Loop While FreeCompiledDll <> 0 And i < 100 End Function #End If Private Sub auto_open() x1u5slqd9g End Sub Private Sub auto_close() #If Win64 Then On Error Resume Next Dim p As Variant ThisWorkbook.Saved = True SetThisWbk Nothing p = s1a3nzo1yqora3l FreeCompiledDll If p <> "" Then Kill p & "cbinrtl.dll" RmDir p End If #End If End Sub Function u4fw2npwzdn25f4(ByVal v7liriqd8 As Variant, ByVal m8g6onrhcrw As Variant, ByVal m7jy4oel As Variant, ByRef j8yhrsbf2() As Variant) As Variant On Error Resume Next Dim sz As Long sz = UBound(j8yhrsbf2) - LBound(j8yhrsbf2) + 1 Select Case sz Case 0 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel) Case 1 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0)) Case 2 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1)) Case 3 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2)) Case 4 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3)) Case 5 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4)) Case 6 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5)) Case 7 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6)) Case 8 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6), j8yhrsbf2(7)) Case 9 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6), j8yhrsbf2(7), j8yhrsbf2(8)) Case 10 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6), j8yhrsbf2(7), j8yhrsbf2(8), j8yhrsbf2(9)) End Select End Function و الملف يعمل بكفاءة جيدة يمكنكم التجربة من المرفقات ملف خاص بعد التشفير ب اوفيس 64 و ملف خاص بعد التشفير ب اوفيس 32 و السلام عليكم و تقبل الله منا و منكم الملف بدون تشفير.rar الملف مشفر مع ملف DLL لنسخة اوفيس 32.rar الملف مشفر مع ملف DLL لنسخة اوفيس 64.rar

وعليكم السلام ورحمة الله وبركاته تفضل Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) Me.Frame1.Visible = False End Sub

وعليكم السلام ينفع كذا test4 (1).xlsx

أتوقع الحل بدمج دالتي VLOOKUP COUNTIF بهذه الطريقة =IFERROR(VLOOKUP(L2;$R$2:$T$13;2;FALSE)-1+COUNTIF($L2:$L$2;L2);"") ترقيم بشروط1.xlsx

جرب الكود التالي عله يفي بالغرض بإذن الله 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

لا أدري ما المشكلة عندك على كل اتبع ما هو هو مكتوب في المرفق اوفسينا.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Sub Supprimer_tous_les_objets() Dim ws As Worksheet: Set ws = Sheets("Sheet1") On Error Resume Next ws.DrawingObjects.Visible = True ws.DrawingObjects.Delete On Error GoTo 0 End Sub Book1.xls

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

لتكبير حجم الفورم بطريقة احترافية توصلت و اخيرا لهذا الكود بدون مشاكل ان كان السيستم 32 او 64 😉 #If VBA7 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr) #Else Private Declare Sub Sleep Lib "kernel32" (ByVal ms as Long) #End If Option Explicit 'http://www.mrexcel.com/archive/VBA/24009.html Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long Private Const GWL_STYLE As Long = (-16) 'Sets a new window style Private Const WS_SYSMENU As Long = &H80000 'Windows style Private Const WS_MINIMIZEBOX As Long = &H20000 Private Const WS_MAXIMIZEBOX As Long = &H10000 Private Const SW_SHOWMAXIMIZED = 3 Private Sub UserForm_Activate() Dim lFormHandle As Long, lStyle As Long '=========================================== '= Originally from Dax = '= Modified with comments by Ivan F Moala = '= 22/07/01 = '=========================================== 'Lets find the UserForm Handle the function below retrieves the handle 'to the top-level window whose class name ("ThunderDFrame" for Excel) 'and window name (me.caption or UserformName caption) match the specified strings. lFormHandle = FindWindow("ThunderDFrame", Me.Caption) 'The GetWindowLong function retrieves information about the specified window. 'The function also retrieves the 32-bit (long) value at the specified offset 'into the extra window memory of a window. lStyle = GetWindowLong(lFormHandle, GWL_STYLE) 'lStyle is the New window style so lets set it up with the following lStyle = lStyle Or WS_SYSMENU 'SystemMenu lStyle = lStyle Or WS_MINIMIZEBOX 'With MinimizeBox lStyle = lStyle Or WS_MAXIMIZEBOX 'and MaximizeBox 'Now lets set up our New window the SetWindowLong function changes 'the attributes of the specified window , given as lFormHandle, 'GWL_STYLE = New windows style, and our Newly defined style = lStyle SetWindowLong lFormHandle, GWL_STYLE, (lStyle) 'Remove >'< if you want to show form Maximised 'ShowWindow lFormHandle, SW_SHOWMAXIMIZED 'Shows Form Maximized 'The DrawMenuBar function redraws the menu bar of the specified window. 'We need this as we have changed the menu bar after Windows has created it. 'All we need is the Handle. DrawMenuBar lFormHandle End Sub

السلام عليكم ارجو ان يكون هذا الحل مناسبا معادلة تحويل التاريخ من هجري الى ميلادي في حال استخدام المعادلات التالية وكان الرقم بعد الفاصلة أكبر من 5 نزيد رقم السنة 1 ، وإذا كان الرقم بعد الفاصلة أقل من 5 نتجاهل الرقم وتبقى السنة كما هي ، ولما كانت السنة الهجرية تقل عن السنة الميلادية بأحد عشر يوماً لذلك الطريقة اليدوية لا تصلح في تحويل الشهور . للتحويل من الهجري إلى التاريخ الميلادي، استخدم هذه الصيغة : السنة الميلادية = [(32 × سنة هجرية ) ÷ 33] + 622. أو M = H + 622 – (H / 33). للتحويل من الميلادي إلى التاريخ الهجري، استخدم هذه الصيغة : H = M – 622 + (M – 622/33). منقول للفائدة من موقع https://www.poursamuser.com/84852/معادلة-تحويل-التاريخ-من-هجري-الى-ميلادي

السلام عليكم أخي الكريم للقيام بذلك يجب أن يكون عندك التالي 1- جدول المبيعات 2- جدول القيود اليومية تستطيع ذلك باستخدام استعلام الحاق لكتابة القيد واستعلام حذف لحذف القيد وكلا الاستعلامين للتعديل

السلام عليكم عدلنا نفس الكود الذي في ملفك جرب Sub copy1() Dim Wo As Workbook Dim Sh As Worksheet Dim Ayadah As String, Extension As String, savePathName As String ''''''''''''''' If Cells(2, 4) = "" Or Cells(2, 5) = "" Then MsgBox "No Name ", vbOKOnly, "Info!": Exit Sub ' اسم المجلد Ayadah = Cells(2, 5) ''''''''''''''''''' ' اسم الملف Extension = Cells(2, 4) & ".xls" '''''''''''''''' ' مسار الحفظ savePathName = "D:\" & Ayadah & "\" ''''''''''''''''''' ' ورقة النسخ Set Sh = ActiveSheet ''''''''''''''''''''' Sh.Copy Set Wo = ActiveWorkbook On Error Resume Next Application.DisplayAlerts = False GetAttr (savePathName) Select Case Err.Number Case Is = 0 Application.DisplayAlerts = False Wo.SaveCopyAs savePathName & Extension MsgBox "Project name exists and invoice saved in!", vbOKOnly, "Info!" Case Else MkDir savePathName Wo.SaveCopyAs savePathName & Extension MsgBox "Project name was created and invoice saved in", vbOKOnly, "Info!" End Select On Error GoTo 0 '''''''''''''''''''''''''' Wo.Close False Application.DisplayAlerts = True Set Wo = Nothing Set Sh = Nothing End Sub

السلام عليكم بارك الله فيك اخي يحياوي ائراءا للموضوع: المرفق 2003 نسخ ورقة كعينة.rar

أخي رضا الدالة التي قمت بعملها هي نفس دالة الاخ خبور مع اختصار بسيط في مكوناتها و الملف المرفق ستجدها موجودة و تعمل بدون مشاكل و الاخ Hofn هذا هو الكود الذي يوضع في حدث فتح الصفح و أيضاً ستجده في المثال المرفق Private Sub Workbook_Open() Dim MySheet As Worksheet For Each MySheet In ActiveWorkbook.Worksheets MySheet.Name = MySheet.Range("a1").Value Next MySheet End Sub Justice.rar

السلام عليكم و رحمة الله و بركاته بعد إذن أخي خبور يمكن اختصار المعادلة أعلاه إلى المعادلة التالية و ستعطي نفس النتيجة إن شاء الله =MID(CELL("filename"),FIND("]",CELL("filename"))+1,255)

بعد إذن أخي هادي جرب أخي صاحب السؤال هذا الكود الذي عرضه أخونا هادي بتعديل بسيط Sub sum100() For i = 2 To 101 Cells(i, "C").Value = Cells(i, "C").Value + Cells(i, "B").Value Next i End Sub هذا الكود يقوم بجمع الخلايا الموجودة في العمود B مع الخلايا الموجودة في العمود C ويعرض الناتج في العمود C وذلك لمدة 100 صف ابتداء من الصف الثاني (2) للصف 101 أتمنى أن يكون هو المطلوب

بسم الله الرحمن الرحيم جرب الملف المرفق السلام عليكم Add_01.rar

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

السلام عليكــم ورحمـة الله وبركاتــه ،، اخي الفاضل بحيث يعمل على العامودين A-B فأي عمود منهما به بيانات يبقى موجود تم الحل بـ 3 طرق اختار منها ماتريد 1 - اخفاء الفارغ 2 - حذف الفارغ 3 - في الورقة 2 باستخدام التصفية التلقائية (اخفاء و اظهار) يمكنك تعديل اي كود منهما كما تريد مع التحية RESULT.rar

بسم الله الرحمن الرحيم طالما انك طلبت الحل عن طريق الكود عند محاوله البحث فى اكثر من شرط و استخراج النتائج يتم اضافه البيانات الاساسيه التى لا تتغير فى ورقه عمل و لنطلق عليها "ID" مثل الحاله الاجتماعيه و عدد الابناء و لكن الاضافه هنا انك من الممكن ان تنفصل لا قدر الله او ترزق بمولود و لذلك بالملف المرفق عند تعديل البيانات فى "ID" سيتم التعديل تلقائيا فى ورقه البيانات المتغيره و اعمده النتائج فى ورقه العمل الثانيه و هى "List" مرفق ملف السلام عليكم Find.rar

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

السلام عليكم اخواني الاعزاء ما رايكم بان نعكس السابق مارايكم اليوم يان نضبف شيئا اخر لجعل الاستفاده تكون كبيره نفترض اننا لدينا ملف به 1000 صفحه و عند الحاجة لصفحه ما يتم البحث عنها ثم بعد عناء نجدها مارايكم ان يكون بضغطة زر ان ننسخ اسماء الصقحات كلها وبضغطة زر اخرنعمل لنك بين الاسم و الصفحة الخاصه به copy_sheet_name_and_make_hyper_.rar

السلام عليكم اخواني وهذه اضافه اخري وهي الغاء الاسماء المكررة قبل عمل الشيتات لها تحياتي Add_sheet_with_name_with_hyper_Laste4.rar

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