husain alhammadi

"الزملاء/الكرام، باطلاعكم على التفاصيل المرفقة، تجدون أن المبادرة/المشروع/الموضوع [القرآن الكريم] بات تحت تصرفكم المباشر. لكم كامل الصلاحية والحق في تقرير المسار الأنسب والمضي قدمًا في عملية التطوير التي ترونها مثالية. انا اثق في رؤيتكم وقدرتكم على تحديد أفضل الخيارات لتنميته ودفعه نحو الأمام. انا على استعداد لتقديم أي دعم أو معلومات إضافية قد تحتاجونها. مع أطيب التمنيات بالتوفيق والنجاح،"

السلام عليكم و رحمة الله و بركاتة الزملاء الكرام وأعضاء المنتدى الموقرين، تحية طيبة وبعد، نتشرف بإبلاغكم، بفضل الله وتوفيقه، اكتمال المرحلة التطويرية النهائية لتطبيقنا المبارك: [القرآن الكريم]. نأمل أن يكون هذا العمل وقفاً رقمياً مستداماً، وأن يكتب أجره لمن ساهم في إنجازه مادياً وتقنياً. دعوة للمراجعة الفنية وضمان الجودة (Quality Assurance): قبل الإطلاق الرسمي والتعميم، ندعوكم، خاصةً من ذوي الخبرة التقنية والمستخدمين المتمرسين، لتحميل النسخة التجريبية والمشاركة في مراجعتها بدقة وعمق. إن الهدف الجوهري من هذه المرحلة هو: ضمان جودة الأداء: والتأكد من توافق التطبيق مع المعايير التقنية واحتياجات شرائح المستخدمين المتنوعة. تحديد نقاط التحسين: واكتشاف أي مواطن خلل أو قصور فني ووظيفي يتطلب تعديلاً. تحقيق التكاملية: للوصول إلى أفضل تجربة مستخدم ممكنة. نؤكد استعداد فريق العمل لدمج وتطبيق الملاحظات البنّاءة التي تصب في مصلحة الهدف العام للتطبيق، مع الالتزام التام بإعادة نشر النسخة المحسّنة والموثقة لجميع المساهمين والجمهور، تحقيقاً لمبدأ "الصدقة الجارية والمنفعة العامة". ختاماً، ندعو المولى عز وجل أن يتقبل هذا الجهد المشترك وأن يجعله في ميزان حسنات كل من شارك في بناء هذا العمل وفي تحسينه ونشره. مع خالص التقدير والامتنان، حسين الحمادي ابو يوسف القران الكريم.xlsm

السلام عليكم و رحمة الله و بركاتة تحية طيبة أعضاء منتدانا الكرام، بقلوب ملؤها الشكر والامتنان، وبفضل الله وتوفيقه، نعلن لكم عن الانتهاء بنجاح من تطوير برنامجنا المبارك: [محضر الاجتماع]، والذي نأمل أن يكون صدقة جارية لنا جميعاً، ولمن ساهم فيه مادياً أو معنوياً. نداء للمعاينة والملاحظات (لإتمام الصدقة الجارية): لقد تم إنجاز البرنامج وتهيئته للنشر، ولكن قبل إطلاقه بشكل رسمي ليستفيد منه الجميع، نرجو منكم، أيها الخبراء والمستخدمون الكرام، معاينة البرنامج بدقة وإبداء ملاحظاتكم القيمة حوله. هدفنا من هذه الخطوة هو: ضمان جودة البرنامج وتوافقه مع احتياجات مختلف المستخدمين. اكتشاف أي قصور أو نقاط تحتاج إلى تحسين وتعديل. جعله أداة متكاملة وسهلة الاستخدام قدر الإمكان. نحن على استعداد تام لتعديل الملاحظات التي تتناسب مع الهدف العام للبرنامج، شريطة أن يتم بعد ذلك إعادة نشر النسخة المعدلة لجميع الأعضاء والمهتمين، ليتحقق مبدأ "الصدقة الجارية" والاستفادة العامة. أخيراً، ندعو الله أن يتقبل هذا الجهد المشترك في ميزان حسنات كل من شارك في إنجاز البرنامج، وكل من سيشارك في تحسينه ونشره. محضر الاجتماع.xlsm

السلام عليكم و رحمة الله و بركاتة عبدالله بشير عبدالله جزاك الله خير الجزاء تم التجربة و ممتاز ارفق لكم البرنامج بعد التعديل لمن يريد الاستفادة منه محضر الاجتماع.xlsm

السلام عليكم و رحمة الله و بركاتة اخواني ارفق لكم الكود مع الملف و ارجوا مساعدتي في حلها لانها لا تعمل و شكرا لكم Private Sub CommandButton2_Click() Dim wsSource As Worksheet Set wsSource = ThisWorkbook.Sheets("Sheet4") wsSource.Range("B3, D4, D5, D6, C54, C57:C59, B61, C11:C17, E11:E17, G11:G17, C21:C27, E21:E27, G21:G27, B37:B43, B47:B51, G47:G51, C31:C34, G31:G34").ClearContents End Sub محضر الاجتماع.xlsm

السلام عليكم و رحمة الله و بركاتة اخواني تم حل المشكلة محضر الاجتماع.xlsm

Private Sub CommandButton1_Click() Dim wsSource As Worksheet Dim wsDestination As Worksheet Dim NextRow As Long On Error GoTo ErrorHandler ' 1. تعيين أوراق العمل Set wsSource = ThisWorkbook.Sheets("Sheet1") Set wsDestination = ThisWorkbook.Sheets("Sheet2") ' 2. إيجاد الصف التالي الفارغ NextRow = wsDestination.Cells(wsDestination.Rows.Count, "B").End(xlUp).Row + 1 ' ضمان أن يبدأ النقل من الصف 3 على الأقل If NextRow < 3 Then NextRow = 3 ' 3. نقل القيم wsDestination.Cells(NextRow, "A").Value = wsSource.Range("D4").Value wsDestination.Cells(NextRow, "B").Value = wsSource.Range("B3").Value wsDestination.Cells(NextRow, "C").Value = wsSource.Range("D5").Value wsDestination.Cells(NextRow, "D").Value = wsSource.Range("D6").Value wsDestination.Cells(NextRow, "E").Value = wsSource.Range("G4").Value wsDestination.Cells(NextRow, "F").Value = wsSource.Range("G5").Value wsDestination.Cells(NextRow, "G").Value = wsSource.Range("G6").Value wsDestination.Cells(NextRow, "S").Value = wsSource.Range("C54").Value wsDestination.Cells(NextRow, "T").Value = wsSource.Range("C57").Value wsDestination.Cells(NextRow, "U").Value = wsSource.Range("C58").Value wsDestination.Cells(NextRow, "V").Value = wsSource.Range("C59").Value wsDestination.Cells(NextRow, "W").Value = wsSource.Range("B61").Value ' نقل النطاقات العمودية wsDestination.Range("I" & NextRow & ":I" & NextRow + 6).Value = wsSource.Range("E11:E17").Value wsDestination.Range("J" & NextRow & ":J" & NextRow + 6).Value = wsSource.Range("G11:G17").Value wsDestination.Range("K" & NextRow & ":K" & NextRow + 6).Value = wsSource.Range("C21:C27").Value wsDestination.Range("L" & NextRow & ":L" & NextRow + 6).Value = wsSource.Range("E21:E27").Value wsDestination.Range("M" & NextRow & ":M" & NextRow + 6).Value = wsSource.Range("G21:G27").Value wsDestination.Range("P" & NextRow & ":P" & NextRow + 6).Value = wsSource.Range("B37:B43").Value ' نقل النطاقات المتوسطة wsDestination.Range("Q" & NextRow & ":Q" & NextRow + 4).Value = wsSource.Range("B47:B51").Value wsDestination.Range("R" & NextRow & ":R" & NextRow + 4).Value = wsSource.Range("G47:G51").Value ' نقل النطاقات القصيرة wsDestination.Range("N" & NextRow & ":N" & NextRow + 3).Value = wsSource.Range("C31:C34").Value wsDestination.Range("O" & NextRow & ":O" & NextRow + 3).Value = wsSource.Range("G31:G34").Value ' 4. مسح المعلومات من ورقة المصدر (Sheet1) With wsSource .Range("D4, B3, D5, D6, G4, G5, G6, C54").ClearContents .Range("C57, C58, C59, B61").ClearContents .Range("E11:E17, G11:G17, C21:C27, E21:E27, G21:G27, B37:B43").ClearContents .Range("B47:B51, G47:G51").ClearContents .Range("C31:C34, G31:G34").ClearContents End With ' 5. رسالة النجاح MsgBox "تم نقل البيانات بنجاح إلى الصف " & NextRow & " وتم مسح البيانات المصدر من Sheet1.", vbInformation Exit Sub ErrorHandler: Application.CutCopyMode = False MsgBox "حدث خطأ في تحديد أوراق العمل. الرجاء التأكد من مطابقة اسم الورقة تمامًا لما هو مكتوب في علامة تبويب Excel." & vbCrLf & "الخطأ: " & Err.Description, vbCritical End Sub بالنسبة للترحيل تم حل المشكلة و المتبقي مسح البيانات من sheet1 بعد نقل المعلوات الى sheet2 محضر الاجتماع.xlsm

Private Sub CommandButton1_Click() Application.ScreenUpdating = False Dim wsSource As Worksheet Dim wsTarget As Worksheet Dim NextRow As Long Dim i As Long Dim StartRow As Long Set wsSource = Worksheets("Sheet1") Set wsTarget = Worksheets("Sheet2") StartRow = wsTarget.Cells(Rows.Count, "A").End(xlUp).Row + 1 NextRow = StartRow If NextRow < 3 Then NextRow = 3 For i = 0 To 5 wsTarget.Cells(NextRow, "A").Value = wsSource.Range("D4").Value wsTarget.Cells(NextRow, "B").Value = wsSource.Range("B3").Value wsTarget.Cells(NextRow, "C").Value = wsSource.Range("D5").Value wsTarget.Cells(NextRow, "D").Value = wsSource.Range("D6").Value wsTarget.Cells(NextRow, "E").Value = wsSource.Range("G4").Value wsTarget.Cells(NextRow, "F").Value = wsSource.Range("G5").Value wsTarget.Cells(NextRow, "G").Value = wsSource.Range("G6").Value wsTarget.Cells(NextRow, "H").Value = wsSource.Range("C" & (11 + i)).Value wsTarget.Cells(NextRow, "I").Value = wsSource.Range("E" & (11 + i)).Value If i < 5 Then wsTarget.Cells(NextRow, "J").Value = wsSource.Range("G" & (11 + i)).Value Else wsTarget.Cells(NextRow, "J").Value = wsSource.Range("G17").Value End If NextRow = NextRow + 1 Next i For i = 0 To 6 wsTarget.Cells(NextRow, "A").Value = wsSource.Range("D4").Value wsTarget.Cells(NextRow, "B").Value = wsSource.Range("B3").Value wsTarget.Cells(NextRow, "C").Value = wsSource.Range("D5").Value wsTarget.Cells(NextRow, "D").Value = wsSource.Range("D6").Value wsTarget.Cells(NextRow, "E").Value = wsSource.Range("G4").Value wsTarget.Cells(NextRow, "F").Value = wsSource.Range("G5").Value wsTarget.Cells(NextRow, "G").Value = wsSource.Range("G6").Value wsTarget.Cells(NextRow, "K").Value = wsSource.Range("C" & (21 + i)).Value wsTarget.Cells(NextRow, "L").Value = wsSource.Range("E" & (21 + i)).Value wsTarget.Cells(NextRow, "M").Value = wsSource.Range("G" & (21 + i)).Value NextRow = NextRow + 1 Next i For i = 0 To 3 wsTarget.Cells(NextRow, "A").Value = wsSource.Range("D4").Value wsTarget.Cells(NextRow, "B").Value = wsSource.Range("B3").Value wsTarget.Cells(NextRow, "C").Value = wsSource.Range("D5").Value wsTarget.Cells(NextRow, "D").Value = wsSource.Range("D6").Value wsTarget.Cells(NextRow, "E").Value = wsSource.Range("G4").Value wsTarget.Cells(NextRow, "F").Value = wsSource.Range("G5").Value wsTarget.Cells(NextRow, "G").Value = wsSource.Range("G6").Value wsTarget.Cells(NextRow, "N").Value = wsSource.Range("C" & (31 + i)).Value wsTarget.Cells(NextRow, "O").Value = wsSource.Range("G" & (31 + i)).Value NextRow = NextRow + 1 Next i For i = 0 To 6 wsTarget.Cells(NextRow, "A").Value = wsSource.Range("D4").Value wsTarget.Cells(NextRow, "B").Value = wsSource.Range("B3").Value wsTarget.Cells(NextRow, "C").Value = wsSource.Range("D5").Value wsTarget.Cells(NextRow, "D").Value = wsSource.Range("D6").Value wsTarget.Cells(NextRow, "E").Value = wsSource.Range("G4").Value wsTarget.Cells(NextRow, "F").Value = wsSource.Range("G5").Value wsTarget.Cells(NextRow, "G").Value = wsSource.Range("G6").Value wsTarget.Cells(NextRow, "P").Value = wsSource.Range("B" & (37 + i)).Value NextRow = NextRow + 1 Next i For i = 0 To 4 wsTarget.Cells(NextRow, "A").Value = wsSource.Range("D4").Value wsTarget.Cells(NextRow, "B").Value = wsSource.Range("B3").Value wsTarget.Cells(NextRow, "C").Value = wsSource.Range("D5").Value wsTarget.Cells(NextRow, "D").Value = wsSource.Range("D6").Value wsTarget.Cells(NextRow, "E").Value = wsSource.Range("G4").Value wsTarget.Cells(NextRow, "F").Value = wsSource.Range("G5").Value wsTarget.Cells(NextRow, "G").Value = wsSource.Range("G6").Value wsTarget.Cells(NextRow, "Q").Value = wsSource.Range("B" & (47 + i)).Value wsTarget.Cells(NextRow, "R").Value = wsSource.Range("G" & (47 + i)).Value NextRow = NextRow + 1 Next wsTarget.Cells(NextRow, "A").Value = wsSource.Range("D4").Value wsTarget.Cells(NextRow, "B").Value = wsSource.Range("B3").Value wsTarget.Cells(NextRow, "C").Value = wsSource.Range("D5").Value wsTarget.Cells(NextRow, "D").Value = wsSource.Range("D6").Value wsTarget.Cells(NextRow, "E").Value = wsSource.Range("G4").Value wsTarget.Cells(NextRow, "F").Value = wsSource.Range("G5").Value wsTarget.Cells(NextRow, "G").Value = wsSource.Range("G6").Value wsTarget.Cells(NextRow, "S").Value = wsSource.Range("C54").Value wsTarget.Cells(NextRow, "T").Value = wsSource.Range("C57").Value wsTarget.Cells(NextRow, "U").Value = wsSource.Range("C58").Value wsTarget.Cells(NextRow, "V").Value = wsSource.Range("C59").Value wsTarget.Cells(NextRow, "W").Value = wsSource.Range("B61").Value Application.ScreenUpdating = True MsgBox "تم ترحيل البيانات بنجاح إلى " & (NextRow) & " صفوف.", vbInformation End Sub السلام عليكم و رحمة الله و بركاتة ارفق لكم المرفق بعد التعديل و لا يزال لايتم الترحيل و في الملف يوجد رقم سري 123 و لكم مني جزيل الشكر محضر الاجتماع.xlsm

السلام عليكم و رحمة الله و بركاتة بارك الله فيك Foksh و جزاك الله خير الجزاء و زادك الله علما الكود لا يرحل الى sheet2

السلام عليكم و رحمة الله و بركاتة ارجوا مساعدتي في تعديل الكود التالي Private Sub CommandButton1_Click() ' إيقاف تحديث الشاشة لتسريع العملية Application.ScreenUpdating = False Dim wsSource As Worksheet Dim wsTarget As Worksheet Dim NextRow As Long ' تحديد ورقة العمل المصدر (Sheet1) وورقة العمل الهدف (Sheet2) Set wsSource = Worksheets("Sheet1") Set wsTarget = Worksheets("Sheet2") ' 1. البحث عن الصف الفارغ التالي في العمود A NextRow = wsTarget.Cells(Rows.Count, "A").End(xlUp).Row + 1 ' 2. ضمان أن يبدأ ترحيل البيانات من الصف رقم 3 على الأقل If NextRow < 3 Then NextRow = 3 ' ------------------------------------------------------------- ' نقل البيانات إلى الصف الجديد (NextRow) في Sheet2 ' ------------------------------------------------------------- ' الأعمدة A إلى F wsTarget.Cells(NextRow, "A").Value = wsSource.Range("D4").Value wsTarget.Cells(NextRow, "B").Value = wsSource.Range("D5").Value wsTarget.Cells(NextRow, "C").Value = wsSource.Range("D6").Value wsTarget.Cells(NextRow, "D").Value = wsSource.Range("H4").Value wsTarget.Cells(NextRow, "E").Value = wsSource.Range("H5").Value wsTarget.Cells(NextRow, "F").Value = wsSource.Range("H6").Value ' الأعمدة G, H, I (القيم الأخيرة هي التي تُحفظ) wsTarget.Cells(NextRow, "G").Value = wsSource.Range("E11").Value wsTarget.Cells(NextRow, "H").Value = wsSource.Range("G11").Value wsTarget.Cells(NextRow, "I").Value = wsSource.Range("C12").Value wsTarget.Cells(NextRow, "H").Value = wsSource.Range("E12").Value wsTarget.Cells(NextRow, "I").Value = wsSource.Range("G12").Value wsTarget.Cells(NextRow, "H").Value = wsSource.Range("E13").Value wsTarget.Cells(NextRow, "I").Value = wsSource.Range("G13").Value wsTarget.Cells(NextRow, "G").Value = wsSource.Range("E14").Value wsTarget.Cells(NextRow, "I").Value = wsSource.Range("G14").Value wsTarget.Cells(NextRow, "G").Value = wsSource.Range("E15").Value wsTarget.Cells(NextRow, "I").Value = wsSource.Range("G15").Value wsTarget.Cells(NextRow, "G").Value = wsSource.Range("E16").Value wsTarget.Cells(NextRow, "I").Value = wsSource.Range("G16").Value wsTarget.Cells(NextRow, "G").Value = wsSource.Range("E17").Value wsTarget.Cells(NextRow, "I").Value = wsSource.Range("G17").Value ' الأعمدة J و L (القيم الأخيرة هي التي تُحفظ) wsTarget.Cells(NextRow, "J").Value = wsSource.Range("C21").Value wsTarget.Cells(NextRow, "L").Value = wsSource.Range("G21").Value wsTarget.Cells(NextRow, "J").Value = wsSource.Range("C22").Value wsTarget.Cells(NextRow, "L").Value = wsSource.Range("G22").Value wsTarget.Cells(NextRow, "J").Value = wsSource.Range("C23").Value wsTarget.Cells(NextRow, "L").Value = wsSource.Range("G23").Value wsTarget.Cells(NextRow, "J").Value = wsSource.Range("C24").Value wsTarget.Cells(NextRow, "L").Value = wsSource.Range("G24").Value wsTarget.Cells(NextRow, "J").Value = wsSource.Range("C25").Value wsTarget.Cells(NextRow, "L").Value = wsSource.Range("G25").Value wsTarget.Cells(NextRow, "J").Value = wsSource.Range("C26").Value wsTarget.Cells(NextRow, "L").Value = wsSource.Range("G26").Value wsTarget.Cells(NextRow, "J").Value = wsSource.Range("C27").Value wsTarget.Cells(NextRow, "L").Value = wsSource.Range("G27").Value ' الأعمدة M و N (القيم الأخيرة هي التي تُحفظ) wsTarget.Cells(NextRow, "M").Value = wsSource.Range("C31").Value wsTarget.Cells(NextRow, "N").Value = wsSource.Range("H31").Value wsTarget.Cells(NextRow, "M").Value = wsSource.Range("C32").Value wsTarget.Cells(NextRow, "N").Value = wsSource.Range("H32").Value wsTarget.Cells(NextRow, "M").Value = wsSource.Range("C33").Value wsTarget.Cells(NextRow, "N").Value = wsSource.Range("H33").Value wsTarget.Cells(NextRow, "M").Value = wsSource.Range("C34").Value wsTarget.Cells(NextRow, "N").Value = wsSource.Range("H34").Value ' الأعمدة O, C, P, Q (القيم الأخيرة هي التي تُحفظ) wsTarget.Cells(NextRow, "O").Value = wsSource.Range("B38").Value wsTarget.Cells(NextRow, "C").Value = wsSource.Range("B39").Value wsTarget.Cells(NextRow, "O").Value = wsSource.Range("B40").Value wsTarget.Cells(NextRow, "C").Value = wsSource.Range("B41").Value wsTarget.Cells(NextRow, "O").Value = wsSource.Range("B42").Value wsTarget.Cells(NextRow, "P").Value = wsSource.Range("B47").Value wsTarget.Cells(NextRow, "P").Value = wsSource.Range("B48").Value wsTarget.Cells(NextRow, "O").Value = wsSource.Range("B49").Value wsTarget.Cells(NextRow, "Q").Value = wsSource.Range("H49").Value wsTarget.Cells(NextRow, "Q").Value = wsSource.Range("H50").Value wsTarget.Cells(NextRow, "Q").Value = wsSource.Range("H51").Value ' الأعمدة R, S, T, U wsTarget.Cells(NextRow, "R").Value = wsSource.Range("C57").Value wsTarget.Cells(NextRow, "S").Value = wsSource.Range("C58").Value wsTarget.Cells(NextRow, "T").Value = wsSource.Range("C59").Value wsTarget.Cells(NextRow, "U").Value = wsSource.Range("B59").Value ' إعادة تشغيل تحديث الشاشة Application.ScreenUpdating = True MsgBox "تم ترحيل البيانات بنجاح إلى ورقة العمل 'Sheet2' في الصف رقم " & NextRow & ".", vbInformation End Sub محضر الاجتماع.xlsm

السلام عليكم و رحمة الله و بركاتة مرحباً بالجميع، لقد قمت بإنجاز برنامج يعمل بشكل جيد، وأحتاج الآن إلى إضافة ميزة تحويل النص إلى صوت (Text-to-Speech) كخطوة أخيرة. المطلوب: كود VBA يتم تشغيله على ملفات Excel، يقوم بتحويل النصوص الموجودة في العمود C من كل ورقة عمل (Sheet) إلى صوت، ربما بوجود زر تشغيل في كل ملف أو عن طريق ماكرو مخصص. الهدف: قراءة محتويات العمود C صوتيًا لتسهيل التدقيق والمراجعة. هل يمكن لأحد أن يشارك كود VBA الذي يمكن أن ينجز هذه المهمة؟ أو هل هناك دالة جاهزة في VBA يمكنها القيام بذلك؟ شكرًا جزيلاً لكم على المساعدة والوقت Copy of تجربة 4.xlsm

Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = vbKeyEscape Then Unload Me KeyCode = 0 End If End Sub عليكم السلام و رحمة الله و بركاتة جرب هذا الكود

هل يمكن اضاف هذ الكود للملف Private Sub CommandButton1_Click() Dim uForm As Object Dim i As Long Dim MyRng As Variant Dim Nameform As String Dim TempName As Variant Dim WaitTime As Double ' قم بإلغاء On Error Resume Next المبدئية MyRng = Sheets("Sheet1").Range("A2:B21").Value Application.Visible = False ' إخفاء التطبيق On Error GoTo ErrorHandler ' معالج أخطاء عام لضمان إعادة الإظهار For i = 1 To UBound(MyRng, 1) TempName = MyRng(i, 1) ' معالجة خطأ القراءة لـ WaitTime On Error Resume Next WaitTime = MyRng(i, 2) If Err.Number <> 0 Then WaitTime = -1 ' تعيين قيمة غير صالحة إذا حدث خطأ Err.Clear On Error GoTo ErrorHandler ' العودة إلى معالج الأخطاء العام ' التحقق من القيمة وتنقيتها If Not IsError(TempName) Then Nameform = Trim(CStr(TempName)) Else Nameform = "" End If ' التحقق من الشروط If Nameform <> "" And IsNumeric(WaitTime) And WaitTime >= 0 Then ' معالجة خطأ عدم وجود النموذج On Error Resume Next Set uForm = UserForms.Add(Nameform) If Err.Number <> 0 Then Application.Speech.Speak "خطأ. النموذج غير موجود: " & Nameform, SpeakAsync:=False Err.Clear On Error GoTo ErrorHandler GoTo NextIteration ' تخطي الدورة الحالية End If On Error GoTo ErrorHandler ' العودة إلى معالج الأخطاء العام Application.Speech.Speak "عرض النموذج: " & Nameform, SpeakAsync:=False If Not uForm Is Nothing Then DoEvents uForm.Show 0 ' تأكد من أن الوقت لا يتجاوز 60 ثانية بشكل مفرط (اختياري) If WaitTime > 60 Then WaitTime = 60 Application.Wait Now + TimeValue("00:00:" & Format(WaitTime, "00")) DoEvents Unload uForm End If Set uForm = Nothing End If NextIteration: Next i ' الخروج الطبيعي Application.Visible = True Exit Sub ' معالج الأخطاء الرئيسي ErrorHandler: Application.Visible = True ' إعادة إظهار التطبيق في حال حدوث خطأ MsgBox "حدث خطأ غير متوقع برقم: " & Err.Number & vbCrLf & "الوصف: " & Err.Description, vbCritical, "خطأ في تشغيل الكود" End Sub Copy of تجربة 4.xlsm

أرغب في التعبير عن شكري العميق لـ الأستاذ محمد هشام. أنت لست مجرد خبير، بل عمود من أعمدة هذا المنتدى. إن حرصك على تقديم الدعم والمشاركة بمعرفتك بتواضع واحترافية هو أمر يُحتذى به. شكرًا لك على كل معلومة قدمتها، وكل سؤال أجبت عنه، وكل توجيه كان في محله Copy of تجربة 4.xlsm

بارك الله فيك الاخ hegazee ترِيد النَّجاح ثقْ بالله ثمَّ بنفْسك وتَجاهَل منْ يقُـول هَذا صعْب وَهذا مستَحيل ، الثِّقة بِالله هِي عقليَّة العُظَماء. اتفق معاك بان البوربوينت يصلح أكثر من الاكسيل لهذا البرنامج و لكن ليس مستحيلة و يوجد الاف برنامج البوربوينت و لكن لا يوجد اكسل فنحن نريد التميز و يد بيد سنصل ان شاء الله و لو كل شخص بفكرة سيكتمل بعون الله

بارك الله فيك الاخ Foksh عن أبي هريرة - رضي الله عنه - قال: قال رسول الله - صلى الله عليه وسلم -: ((والكلمة الطيبة صدقة))؛ الحديث متفق عليه.

السلام عليكم و رحمة الله و بركاتة بارك الله فيك الاخ Foksh و زادك الله علما ارفق لك الملف مرة اخرى الصلاة هي ثاني أركان الإسلام وعمود الدين الإسلامي، فإن صَلُحَت صلاة المسلم، صَلُحَت أعماله وعبادته، كما أنَّ الصلاة هي الصلة بين المسلم وربه، وقد شبهها النبي عليه الصلاة والسلام بالنهر الجاري على باب أحدنا يغتسل منه في اليوم والليلة خمس مرات، فلا يبقى من درنه؛ أي لا يبقى من وسخه شيء، فإن التزم المسلم بها، يغفر له الله تعالى ذنوبه الصغائر يد بيد نجعله من افضل برنامج تعليم الصلاة للاطفال و الكبار . ليكون صدقة جارية للجميع من يساهم التطوير مسموح شرط نشرها تعليم الصلاة للاطفال.xlsm

السلام عليكم ورحمة الله وبركاته، أحبائي وإخواني في منتدانا، كم هو جميل أن نلتقي على الخير ونتعاون عليه! وكم هو أعظم أن نقدم صدقة جارية تبقى بعد رحيلنا. من هذا المنطلق، أود أن أعلن لكم عن إطلاق برنامج لتعليم الصلاة. هذا البرنامج هو مجرد محاولة بسيطة مني لتقديم علم نافع، ليكون صدقة جارية عني وعنكم. إنه مصمم ليكون سهلًا ومباشرًا، ليساعد كل من يسعى لتقوية علاقته مع الله من خلال الصلاة. ما يميز هذا البرنامج؟ تعليم عملي: يغطي خطوات الصلاة من التكبير إلى التسليم، مع إرشادات مبسطة. محتوى موثوق: يعتمد على مصادر شرعية موثوقة لضمان صحة المعلومات. مشاركة الأجر: كل من ينشر هذا البرنامج ويدل عليه، سيكون له أجر من استفاد منه، فالخير لا يكتمل إلا بتعاوننا. أرجو أن يكون هذا العمل في ميزان حسناتنا جميعًا، وأن يجعله الله خالصًا لوجهه الكريم. جزاكم الله خيرًا. أخوكم تعليم الصلاة للاطفال.xlsm

Sub ListFilesInFolderWithHyperlink_Optimized_WithOptions() ' Declares variables for file system objects and Excel ranges. Dim FSO As Object Dim Folder As Object Dim File As Object Dim Rng As Range Dim FolderPath As String Dim LastRow As Long Dim UserChoice As Long ' Define the list of folder paths. Dim FolderPaths(1 To 3) As String FolderPaths(1) = "C:\Users\husain\OneDrive\سطح المكتب\ارشيف\كشف.xlsm" FolderPaths(2) = "C:\Users\husain\OneDrive\سطح المكتب\ارشيف\ملفات" FolderPaths(3) = "C:\Users\husain\OneDrive\سطح المكتب\ارشيف" ' Prompt the user to choose a folder. UserChoice = Application.InputBox(Prompt:="الرجاء اختيار المجلد المطلوب:" & vbCrLf & _ "1: ملف كشف.xlsm" & vbCrLf & _ "2: مجلد ملفات" & vbCrLf & _ "3: مجلد ارشيف", _ Title:="اختيار المجلد", Type:=1) ' Check if the user made a valid choice. If UserChoice >= 1 And UserChoice <= 3 Then ' Set the selected folder path. FolderPath = FolderPaths(UserChoice) Else MsgBox "تم إلغاء العملية أو اختيار غير صالح.", vbExclamation, "إلغاء" Exit Sub End If ' Set the worksheet to be used. With ThisWorkbook.ActiveSheet ' Clears any previous data and hyperlinks from the specified range. LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row If LastRow > 1 Then .Range("B2:B" & LastRow).ClearContents End If .Hyperlinks.Delete ' Create the FileSystemObject. Set FSO = CreateObject("Scripting.FileSystemObject") ' Check if the folder exists. If FSO.FolderExists(FolderPath) Then ' Get the folder object and set the starting cell. Set Folder = FSO.GetFolder(FolderPath) Set Rng = .Range("B2") ' Loop through each file in the folder and add a hyperlink. For Each File In Folder.Files .Hyperlinks.Add Anchor:=Rng, Address:=File.Path, TextToDisplay:=File.Name Set Rng = Rng.Offset(1, 0) Next File ' Loop through each subfolder and add a hyperlink. For Each Folder In Folder.SubFolders .Hyperlinks.Add Anchor:=Rng, Address:=Folder.Path, TextToDisplay:=Folder.Name Set Rng = Rng.Offset(1, 0) Next Folder ' Displays a success message. MsgBox "تمت إضافة أسماء جميع الملفات والمجلدات كروابط تشعبية بنجاح.", vbInformation, "عملية ناجحة" Else ' Displays an error message if the folder path is invalid. MsgBox "مسار المجلد غير موجود. يرجى التحقق من المسار.", vbCritical, "خطأ" End If End With ' Release objects from memory. Set FSO = Nothing Set Folder = Nothing End Sub السلام عليكم ورحمه الله و بركاتة ارجو من اخواتي خبراء تاكد من الكود المرفق و تعديلها و المطلوب 1- عند اضافة في ملف (ملفات) يتم نقلها مباشرة الي ملف كشف مع ارتباط تشعبي 2- في حالة اضافة او تعديل في ملف (ملفات) يتم نقل التعديل مباشرة الي ملف كشف و جزاكم الله خيرا كشف.xlsm

للرفع

اخواني ارجوا مساعدتي فى حصول على تلاوة الشيخ مشاري بن راشد العفاسي الصوت فقط خاص بالصلاة في ثلاثة مقاطع 1- الله اكبر 2- التسليم (سمع الله لمن حمده و السلام عليكم و رحمة الله و بركاتة السلام عليكم و رحمة الله و بركاتة) 3-سمع الله لمن حمده 4- سورة الفاتحة (بدون اعوذ بالله من الشيطان الرجيم ) و جزاكم الله خير الجزاء

السلام عليكم و رحمة الله و بركاتة اسال الله رب العرش العظيم ان يزيد في علمك فعلا هذا المطلوب انت مبدع بمعنى كلمة جزاك الله خير الجزاء استاذى هل يمكن اضافة الصوت للعلم سيتم اضافة الصوت للجميع ما عدا Login_screen بدون صوت اسم نمودج المستخدم الوقت بالثواني ملف الصوت Login_screen 10 UserForm1 45 C:\Users\husain\OneDrive\سطح المكتب\تجربة\اقامة الصلاة.mp3 UserForm2 10 UserForm3 51 C:\Users\husain\OneDrive\سطح المكتب\تجربة\سورة الفاتحة.mp3 UserForm4 21 C:\Users\husain\OneDrive\سطح المكتب\تجربة\سورة الاخلاص.mp3 UserForm6 10 UserForm7 10 UserForm8 10 UserForm9 10 UserForm10 10 UserForm11 10 UserForm3 51 C:\Users\husain\OneDrive\سطح المكتب\تجربة\سورة الفاتحة.mp3 UserForm5 33 C:\Users\husain\OneDrive\سطح المكتب\تجربة\سورة الفلق.mp3 UserForm6 10 UserForm7 10 UserForm8 10 UserForm9 10 UserForm10 10 UserForm12 10 UserForm13 10

السلام عليكم و رحمة الله و بركاتة اخواني الخبراء هل يمكن دمج كودين فى UserForm1 اضافة الصوت WindowsMediaPlayer1 هذا كود يوزرفورم Private Sub CommandButton5_Click() Application.Visible = False On Error Resume Next Login_screen.Show Application.Wait Now + TimeValue("00:00:3") Login_screen.Hide UserForm1.Show UserForm1.Repaint Application.Wait Now + TimeValue("00:00:3") UserForm1.Hide Application.Visible = True End On Error GoTo 0 End Sub هذا كود الصوت Private Sub CommandButton13_Click() WindowsMediaPlayer3.Controls.Play End Sub

للرفع

السلام عليكم و رحمة الله و بركاتة تفضل اظهار الرقم الحقيقي دون كسور.xlsx