husain alhammadi

السلام عليكم و رحمة الله و بركاتة تحية طيبة لكل أعضاء المنتدى الكرام، يسرني أن أعلن عن إنجاز ملف "الجزر والمد" (Tides and Islands). لقد تم تجميع وإعداد هذا الملف بفضل جهودكم ودعمكم المستمر، وبمساعدة أدوات بحث وتحليل متقدمة مثل Gemini، بهدف توفير مرجع شامل ومفيد حول هذا الموضوع الهام، مع تركيز خاص على الموقع/المواقع الجغرافية التي يغطيها التحليل. 🌟 لماذا نحتاج إلى ملاحظاتكم؟ (للتدقيق والتطوير) هذا العمل هو ملك للجميع، ولضمان دقته وفائدته القصوى، فإنني أتوجه إليكم بطلب هام: 1. تسجيل الملاحظات وتصحيح الأخطاء: أرجو من كل من يجد أي خطأ (علمي، لغوي، أو فني)، خاصة فيما يتعلق ببيانات الموقع الجغرافي المشمول في الملف، أو يرى أن هناك معلومة تحتاج إلى تعديل أو توضيح، أن يسجل ملاحظته مشكورًا. 2. التطوير والإضافة: أرحب بأي اقتراحات تهدف إلى تطوير محتوى الملف وإثرائه بمعلومات إضافية، وخصوصًا ما يخص تغطية الموقع، سواء بإضافة إحداثيات، خرائط تفصيلية، أو أي معلومات ذات صلة به. عملنا الجماعي هو سر قوتنا. ساهموا معنا في جعل هذا الملف المرجع الأفضل والأكثر دقة في المنتدى. شكرًا جزيلاً لجهودكم وتعاونكم المثمر. مع خالص التحية والتقدير، ‏‏‏‏الجزر و المد.xlsm

السلام عليكم و رحمة الله و بركاتة هل يوجد خطاء في الكود Private Sub CommandButton1_Click() On Error GoTo ErrorHandler Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim wsSource As Worksheet Dim wsTarget As Worksheet Dim conditionValue As Long Dim startColumnIndex As Long Dim sourceColumnIndex As Long Dim NumberOfRows As Long Dim sourceRange As Range Dim targetRange As Range NumberOfRows = 30 On Error GoTo SheetError Set wsSource = ThisWorkbook.Sheets("Sheet4") Set wsTarget = ThisWorkbook.Sheets("Sheet3") On Error GoTo ErrorHandler If IsNumeric(wsTarget.Range("B2").Value) And Not IsEmpty(wsTarget.Range("B2").Value) Then conditionValue = CLng(wsTarget.Range("B2").Value) Else MsgBox "يجب أن تكون القيمة في الخلية B2 رقمًا يمثل الشهر (1-12).", vbCritical GoTo CleanUp End If If conditionValue >= 1 And conditionValue <= 12 Then startColumnIndex = 1 + (conditionValue - 1) * 6 Else MsgBox "القيمة خارج النطاق المسموح به (1-12).", vbExclamation GoTo CleanUp End If sourceColumnIndex = startColumnIndex + 2 Set sourceRange = wsSource.Range( _ wsSource.Cells(2, sourceColumnIndex), _ wsSource.Cells(1 + NumberOfRows, sourceColumnIndex) _ ) Set targetRange = wsTarget.Range( _ wsTarget.Cells(5, 3), _ wsTarget.Cells(4 + NumberOfRows, 3) _ ) targetRange.Value = sourceRange.Value Application.CutCopyMode = False ThisWorkbook.Save MsgBox "? تم ترحيل البيانات بنجاح وحفظ المصنف.", vbInformation CleanUp: Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Exit Sub ErrorHandler: MsgBox "? حدث خطأ غير متوقع: " & Err.Description, vbCritical Resume CleanUp SheetError: MsgBox "?? خطأ في أسماء أوراق العمل: تأكد من أن أسماء أوراق العمل هي 'Sheet4' و 'Sheet3' بشكل صحيح.", vbCritical Resume CleanUp End Sub ‏‏‏‏الجزر و المد - 999.xlsm

السلام عليكم و رحمة الله و بركاتة تحية طيبة لكم جميعًا، أعضاء منتدانا الكرام، نأمل أن تكونوا بأفضل حال. كما تعلمون، يُعتبر ملف المد والجزر (Tide & Currents) أحد المصادر الهامة والمفيدة التي نعتمد عليها في المنتدى، خاصة للأعضاء المهتمين بالصيد، الملاحة، أو أي نشاط يتطلب معرفة دقيقة بأحوال البحر وحركة المياه. ونظرًا للطبيعة المتغيرة لهذه البيانات وحرصًا منا على توفير أدق وأحدث المعلومات لجميع الأعضاء، نود أن نطلب من كل من لديه نسخة من هذا الملف أو لديه القدرة على الوصول إلى مصادر بيانات أحدث وأكثر شمولاً، مساعدتنا في مراجعته وتحديثه. لماذا نحتاج إلى التحديث؟ الدقة: ضمان أن تكون التوقعات والأرقام المسجلة في الملف حديثة ومطابقة للتغيرات السنوية. الشمولية: إضافة محطات أو مناطق جديدة قد تهم الأعضاء. الصلاحية: التأكد من أن الملف يغطي الفترة الزمنية القادمة بشكل كامل. كيف يمكنكم المساعدة؟ المراجعة: إذا كانت لديكم خبرة في هذا المجال، نرجو مراجعة البيانات الحالية للتأكد من دقتها. التزويد بالملفات الجديدة: إذا كنتم تمتلكون نسخة محدّثة للعام القادم (أو الفترة الحالية)، نرجو مشاركتها. المصادر الموثوقة: مشاركة روابط أو أسماء لجهات أو برامج توفر بيانات دقيقة وموثوقة للمد والجزر. نرجو إرسال أي ملاحظات، تعديلات، أو ملفات محدّثة إلى مشرفي القسم أو الرد مباشرة على هذا الموضوع ليتم تجميعها وتطبيق التعديلات اللازمة. شاكرين لكم تعاونكم المستمر ومساهمتكم القيمة في إثراء منتدانا. مع خالص التقدير، tide_scraper.py.xlsm

🚀 السلام عليكم و رحمة الله و بركاتة أنا سعيد بتقديم هذا البرنامج، ولكي يصبح أداة مثالية لنا جميعًا، نحتاج إلى خبرتكم الجماعية. أدعوكم للمشاركة في تطوير البرنامج من خلال: المقترحات: كيف يمكن تكييف هذه الأداة لتناسب مشاكلنا الثقافية أو اليومية الخاصة؟ التطبيقات: شاركونا أمثلة عن مشكلة شخصية طبقوا عليها "الخمسة لماذا" وماذا كان اكتشافكم الجذري. التحديات: ما هي الصعوبات التي واجهتكم عند محاولة الوصول إلى "لماذا 5"؟ بمشاركتكم، سنجعل من "الخمسة لماذا" منهجية يومية تثري حياتنا. بانتظار مساهماتكم القيمة! مع خالص التقدير، لماذا.xlsx

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

السلام عليكم و رحمة الله و بركاتة الزملاء الكرام وأعضاء المنتدى الموقرين، تحية طيبة وبعد، نتشرف بإبلاغكم، بفضل الله وتوفيقه، اكتمال المرحلة التطويرية النهائية لتطبيقنا المبارك: [القرآن الكريم]. نأمل أن يكون هذا العمل وقفاً رقمياً مستداماً، وأن يكتب أجره لمن ساهم في إنجازه مادياً وتقنياً. دعوة للمراجعة الفنية وضمان الجودة (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- سورة الفاتحة (بدون اعوذ بالله من الشيطان الرجيم ) و جزاكم الله خير الجزاء