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

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

السلام عليكم ورحمة الله وبركاته يسرني اليوم أن أقدم لكم هذه الهدية المتميزة والرائعة (مكتبة الأكواد الخاصة) :: الإصدار الثالث :: مكتبة عامرة بمئات الأكواد 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

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

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

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

تبارك الله ، ما شاء الله ، تصميم رائع وجذاب ولكني للأسف واجهت مشكلة في فتح البرنامج

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

وضح المطلوب اكتر والافضل إرفاق ملف به بيانات لما تريده وتوضيح المطلوب

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

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

شكراً لك اخي العزيز وبارك الله في جهودك الطيبة

اشكركم جميعا على مجهودكم واخص أ احمد عبدالحليم و أ اكسلاوى على جهد المتابعة والوقت واليكم الملف بعد الحصول على نتائج صحيحة 10 %% وهو من الاستاد / محمود حسن من محافظةقنا -مصر وهو ليس عضوا وجزاكم الله خيرا final cod mohaoud test.xlsx

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

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

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

وعليكم السلام ورحمة الله وبركاته تفضل 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

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

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

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

السلام عليكم لم لا يكون الرمز syriainmyheart أرجو لكم التوفيق في عملكم هذا تقبل تحياتي.

السلام عليكم أخي الكريم للقيام بذلك يجب أن يكون عندك التالي 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

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

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