ياسر خليل أبو البراء

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

أخي الكريم سيف النصر أهلا بك في المنتدى ونورت بين إخوانك يرجى تغيير اسم الظهور للغة العربية كما يرجى الإطلاع على موضوع التوجيهات في الموضوعات المثبتة في صدر المنتدى لمعرفة كيفية التعامل بشكل أفضل مع المنتدى بالنسبة لطلبك إليك شرح الكود مع تعديل بسيط ليناسب طلبك كما ذكرت في تعليقات الكود 'تعريف متغير من النوع النصي Dim MyWindow As String Private Sub CommandButton1_Click() 'تعريف المتغيرات Dim xlApp As Application, I As Integer, FilePath 'ليعبر عن تطبيق الإكسيل [xlApp] تعيين قيمة للمتغير المسمى Set xlApp = Application 'تعيين قيمة المتغير النصي ليساوي عنوان النافذة الحالية للملف MyWindow = xlApp.ActiveWindow.Caption 'بدء التعامل مع خاصية نافذة فتح الملفات With xlApp.FileDialog(msoFileDialogOpen) 'عنوان نافذة فتح الملفات .Title = "تحميل الملف" 'إمكانية تحديد أكثر من ملف .AllowMultiSelect = True .Show 'عمل حلقة تكرارية لكل الملفات التي تم تحديدها من قبل المستخدم For Each FilePath In .SelectedItems 'زيادة المتغير بمقدار واحد مع كل حلقة تكرارية I = I + 1 'إذا وجد مسار الملف أي أن الملف موجود يتم تنفيذ السطر التالي If Not FilePath = vbNullString Then Rx3 (FilePath) End If 'الانتقال للملف التالي ضمن الملفات التي تم تحديدها Next FilePath End With 'إغلاق المصنف الحالي مع حفظ التغيرات ThisWorkbook.Close True Exit Sub Err: 'إظهار رسالة خطأ في حالة حدوث خطأ ما MsgBox Err.Description, vbCritical, "Error" End Sub Sub Rx3(Filename As String) 'فتح المصنف عن طريق تحديد مساره Workbooks.Open Filename:=Filename '[Sheet1] تحديد ورقة العمل المسماة Sheets("Sheet1").Select 'وضع نص معين في الخلية الأولى مع جعل الخط أسود عريض With Range("A1") .Value = "YasserKhalil" .Font.Bold = True End With 'إغلاق المصنف النشط مع حفظ التغييرات ActiveWorkbook.Close True End Sub أرجو أن يكون المطلوب .. إليك الملف المرفق فيه شرح الكود مع التعديلات التي تمت تقبل تحياتي Open File Name YasserKhalil.rar

أخي الكريم يرجى تغيير الاسم إلى اسم لائق .. بالنسبة لسؤالك ..الناتج صحيح لكن المشكلة أن الناتج ظهر بشكل غير متوقع لك ..لذا لحل المشكلة يتم تنسيق الناتج بهذا الشكل Sub Test() Dim X X = Format(837987 / 11773501, "#,##0.000000") MsgBox X End Sub يمكن التحكم في عدد الأرقام على يمين العلام العشرية كما تشاء أرجو أن يكون المطلوب تقبل تحياتي

بارك الله فيك أخي مختار وجزيت خيراً على دعائك الطيب ولك بمثل إن شاء الله الحمد لله الذي بنعمته تتم الصالحات تقبل وافر تقديري واحترامي

أخي الكريم إبراهيم قم بتصميم الشهادة على الإكسيل (أو يمكن أن يتبرع أحد الأخوة المحترفين في تصميم الشهادات) ، وبعدها يمكن مساعدتك في تكملة المطلوب تقبل تحياتي

بارك الله فيك أخي الحبيب محتار أيوا كدا خليك معانا وبلاش تغطس يا غطاس .. مشكور على الشرح البسيط المميز

الأخ الفاضل (ثق بي) إن شاء الله نثق فيك أهلاً بك في المنتدى ونورت بين إخوانك يرجى تغيير اسم الظهور للغة العربية هل تريد الحل بالمعادلات أم بالأكواد ؟ (برجاء الإطلاع على موضوع التوجيهات في الموضوعات المثبتة في صدر المنتدى)

حاول أخي الكريم إبراهيم تدرس الكود الأول وشوف أنا اتعاملت إزاي مع المتغيرات ..وإن شاء الله تضبط معاك أعتذر لأنني مشغول جداً الآن .. بس إن شاء الله تقدر تظبطها تقبل تحياتي

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

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

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

أخي الكريم مهند حل الأخ عبد الله الصاري في هذه الحالة هو الأنسب حيث يمكنك تحديد نطاق المعادلات التي سيتم نسخها ثم تحوويلها لقيم بالكود حاول فيها وإذا لم تستطع ارفق ملفك وإن شاء الله ليلاً أعدل لك الكود بحيث يناسب طلبك

تفضل أخي إبراهيم ThisWorkbook.Sheets("Sheet1").Range("A1:A10").Copy wb.Sheets("Sheet1").Range("A1")

أخي الكريم محمد حافظ يرجى تغيير اسم الظهور للغة العربية جرب المعادلة التالية في الخلية L2 .. =TRUNC((K2-J2)*24)&":"&INT(MOD((K2-J2)*24*60,60)) إذا لم تعمل المعادلة غير الفاصلة العادية لفاصلة منقوطة حل آخر أبسط : ----------------- يمكن استخدام المعادلة بهذا الشكل =K2-J2 ثم يتم تنسيق الخلايا التي بها النتائج إلى hh:mm حل ثالث : ------------ =TEXT(K2-J2, "[hh]:mm") تقبل تحياتي

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

أخي الحبيب إبراهيم إليك الكود التالي عله يحل المشكلة (الكود طويل بعض الشيء لأنه يتعامل مع الأخطاء التي يمكن أن تحدث ..فهو تفصيلي ) Sub CreateWorkbook() Dim WB As Workbook Dim Str1 As String, Str2 As String, StrPath As String, StrExt As String Dim sFileName As String, sPath As String, sPathAndFileName As String Dim iFileFormat As Long, iReply As Long Dim bNeedMore As Boolean Set WB = Workbooks.Add Str1 = ThisWorkbook.Sheets("Sheet1").Range("A1").Value Str2 = ThisWorkbook.Sheets("Sheet1").Range("A2").Value StrPath = ThisWorkbook.FullName StrExt = Right(StrPath, Len(StrPath) - InStrRev(StrPath, ".")) Application.ScreenUpdating = False Application.DisplayAlerts = False Select Case StrExt Case "xls" iFileFormat = -4143 Case "xlsb" iFileFormat = 50 Case "xlsx" iFileFormat = 51 Case "xlsm" iFileFormat = 52 End Select sPath = ThisWorkbook.Path & "\" sFileName = Str1 & Str2 & "." & StrExt sPathAndFileName = sPath & sFileName If LJMFileExists(sPathAndFileName) = True Then iReply = MsgBox(Buttons:=vbYesNo, Title:="'Overwrite' or 'Escape' Selection", Prompt:="The File Already Exists. Do You Want To Overwrite The File?" & vbCrLf & "Folder: " & ThisWorkbook.Path & vbCrLf & "File Name: " & Str1 & Str2 & "." & StrExt & vbCrLf & vbCrLf & "Select 'Yes' To Overwrite The File." & vbCrLf & "Select 'No' To Do Nothing.") If iReply = vbNo Then MsgBox "Nothing Done Per User Request." GoTo MYEXIT End If End If On Error Resume Next WB.SaveAs FileFormat:=iFileFormat, Filename:=sPathAndFileName If Err.Number = 0 Then MsgBox "File Saved Successfully.", 64 ElseIf Err.Number = 1004 Then MsgBox "Nothing Done. Destination File Is Already Open Or Is Read/Only." & vbCrLf & "Try Again After The File Is Closed." & vbCrLf & "Folder: " & sPath & vbCrLf & "File Name: " & sFileName Else MsgBox "Nothing Done. File Save Runtime Error " & Err.Number & "." & vbCrLf & "Folder: " & sPath & vbCrLf & "File Name: " & sFileName End If On Error GoTo 0 MYEXIT: 'Resume Normal Error Processing On Error GoTo 0 WB.Close SaveChanges:=False Application.DisplayAlerts = True Application.ScreenUpdating = True Set WB = Nothing End Sub Private Function LJMFileExists(sPathAndFullFileName As String) As Boolean 'This Returns TRUE If File Exists And FALSE If File Does Not exist '----------------------------------------------------------------- Dim iError As Integer Dim iFileAttributes As Integer On Error Resume Next iFileAttributes = GetAttr(sPathAndFullFileName) 'Check The Internal Error Return iError = Err.Number Select Case iError Case Is = 0 iFileAttributes = iFileAttributes And vbDirectory If iFileAttributes = 0 Then LJMFileExists = True Else LJMFileExists = False End If Case Else LJMFileExists = False End Select On Error GoTo 0 End Function تقبل تحياتي

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

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

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

أخي الكريم أبا الحسن والحسين للأسف لا تعمل الأداة مع الإصدارات الحديثة أو ربما لا تعمل على 64 بت .. الرجاء ممن يستخدمون الإصدارات الحديثة 32 بت أن يوافونا بالنتائج

أخي الكريم السيفاني يبدو أن هناك التباس في الأمر عليك بين VB و VBA .. بالنسبة للـ VB الفيجوال بيسك فهذا السطر جائز أي الإعلان عن متغير ووضع قيمة له في نفس السطر أما بالنسبة للـ VBA فلا يجوز ذلك ..بل يتم الإعلان في سطر وتعيين قيمة للمتغير في سطر آخر

أخي الكريم قلم الإكسيل (أما آن لنا أن نتشرف باسم القلم الحقيقي) جزيت خيراً على كلماتك الرقيقة في حقي وعلى دعائك الطيب المبارك ولك بمثل إن شاء الله تقبل وافر تقديري واحترامي

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

أخي الكريم .. العمل تم باستخدام الأكواد .. النتائج تظهر بدايةً من الخلية H45 .. قم بالتالي افتح الملف المرفق الذي أرفقته في المشاركة السابقة اضغط من لوحة المفاتيح Alt + F8 ستظهر نافذة بها اسم الإجراء الفرعي ExtractDuplicateNumbers انقر زر الامر المسمى Run وشاهد النتائج في الصفوف 45 - 69 تقبل تحياتي

أخي الكريم مهند الزيدي جرب الكود التالي عله يفي بالغرض Sub ConvertFormula() With Range("D2:D20") .Formula = "=IF(AND(B2=""ملغى"",C2=""ملغى""),""ملغى"",SUM(B2-C2))" .Value = .Value End With With Range("Z2:Z20") .Formula = "=IFERROR(IF(B2=0,"""",COUNT($Z$1:Z1)+1),"""")" .Value = .Value End With End Sub تقبل تحياتي