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

أخي الكريم مختار الحمد لله أن تم التنفيذ بنجاح ومشكور على متابعتك واهتمامك بالتعلم

أخي الكريم عبد الكريم أهلا بك في المنتدى ونورت المنتدى بين إخوانك إليك الملف المرفق فيه حلين أحدهما بالمعادلات والآخر باستخدام دالة معرفة ... Unique Items YasserKhalil.rar

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

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

أخي الكريم وحيد الحمد لله الذي بنعمته تتم الصالحات ، جزيت خيراً على دعوتك الطيبة تقبل وافر تقديري واحترامي

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

أخي الكريم وحيد في الخلية B2 ضع المعادلة التالية =MOD(A2/1000,1)*1000 ثم قم بسحبها وفي الخلية C2 ضع المعادلة التالية =INT(A2/1000) ثم قم بسحبها إذا صادفتك مشكلة بالمعادلة قم باستبدال الفاصلة العادية في المعادلة بفاصلة منقوطة .. تقبل تحياتي

أخي الحبيب عبد العزيز في انتظار التطبيق .. ويا ريت تطبق ع الجديد .. اللي هو عمله أخونا ياسر العربي أخي الحبيب الغالي ياسر العربي إضافة في قمة الروعة بالتأكيد .. كونك تجعل مسار الملف الصوتي في نفس مسار المصنف (ودا أمر مستحب بالنسبة لي) بس ممكن ييجي واحد رخم زي حالاتي بردو ويقولك لا أنا مش عايز الملف الصوتي في نفس مسار المصنف (رخامة بقا) عموماً إضافة جميلة وأنا أحبذها وأررجحها ودا التعديل الجديد للأخ ياسر العربي الكود بالكامل في الموديول #If VBA7 Then Public Declare PtrSafe Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long #Else Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long #End If Sub PlayWavFile(WavFileName As String, Wait As Boolean) If Dir(WavFileName) = "" Then Exit Sub If Wait Then sndPlaySound WavFileName, 0 Else sndPlaySound WavFileName, 1 End If End Sub Sub PlaySoundNotesInExcel(CellAddress As String) Dim SoundFileName As String, MyPath As String SoundFileName = "" On Error Resume Next MyPath = ThisWorkbook.Path & "\" SoundFileName = MyPath + Range(CellAddress).Comment.Text On Error GoTo 0 If SoundFileName = "" Then Exit Sub If InStr(1, SoundFileName, Chr(10)) > 0 Then SoundFileName = Left(SoundFileName, InStr(1, SoundFileName, Chr(10)) - 1) End If PlayWavFile SoundFileName, False End Sub تم إضافة سطر وتعديل سطر MyPath = ThisWorkbook.Path & "\" SoundFileName = MyPath + Range(CellAddress).Comment.Text بارك الله فيك أخي الغالي ياسر وفي انتظار المزيد من الرخامات المستحبة لي

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

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

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله بدايةً من هذا الموضوع لن أقوم بإرفاق ملفات في الموضوع وسأترك لكم التطبيق العملي بأنفسكم (حتى نتطور) ... كفانا ملفات مرفقة جاهزة فرأيي أن الملفات المرفقة الجاهزة تبعث على الكسل بشكل كبير .. كل ما يقوم به العضو هو تحميل الملف المرفق ثم تجربته ولو تيسر له الأمر قليلاً لألقى نظرة على العمل وعلى الأكواد الموجودة ..وقلما تجد من يدرس الملف المرفق بهدف التعلم من ثم .. فهذا الموضوع موجه لمن يريد ويرغب بالتعلم وليس لمن يريد الملفات الجاهزة .. سأقوم إن شاء ربي بسرد الخطوات ببساطة شديدة يفهمها الجميع (المبتديء قبل المحترف) نبدأ على بركة الله افتح ملف إكسيل جديد (خطوة صعبة بس أنا عارف إن 90% هيقدر على الخطوة دي ) احفظ الملف الجديد بامتداد xlsm أو Excel Macro-Enabled .. لمعرفة المزيد يمكنك الإطلاع على موضوع (بداية الطريق لإنقاذ الغريق) روح لمحرر الاكواد عن طريق Alt + F11 وأدرج موديول جديد من خلال القائمة Insert ثم الأمر Module الصق الكود التالي في الموديول #If VBA7 Then Public Declare PtrSafe Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long #Else Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long #End If Sub PlayWavFile(WavFileName As String, Wait As Boolean) If Dir(WavFileName) = "" Then Exit Sub If Wait Then sndPlaySound WavFileName, 0 Else sndPlaySound WavFileName, 1 End If End Sub Sub PlaySoundNotesInExcel(CellAddress As String) Dim SoundFileName As String SoundFileName = "" On Error Resume Next SoundFileName = Range(CellAddress).Comment.Text On Error GoTo If SoundFileName = "" Then Exit Sub If InStr(1, SoundFileName, Chr(10)) > 0 Then SoundFileName = Left(SoundFileName, InStr(1, SoundFileName, Chr(10)) - 1) End If PlayWavFile SoundFileName, False End Sub هرفق ملف صوتي بامتداد WAV للتطبيق عليه .. الملف باسم TestWAV فك الضغط عن الملف المضغوط هتلافي اسم الملف TestWAV اعمل عليه كليك يمين ثم الأمر Properties أي خصائص روح للتبويب Security (بس اوعى بتوع الأمن يقفشوك) ..المهم هتلاقي سطر بهذا الشكل (مسار الملف الصوتي) C:\Users\Future\Desktop\TestWAV.wav دا هيكون شكل المسار للملف ..طبعاً هيختلف من جهاز لجهاز آخر .. المهم انسخ سطر المسار ده الخطوة التالية ..شوف أي خلية تريد أن يعمل الصوت عند تحديدها ليكن الخلية G7 (أصلي بحب رقم 7 والعمود G هو العمود السابع وفي نفس الوقت الصف السابع .. متدقش على كلامي) كليك يمين على الخلية (بزر الماوس الأيمن يا حاج أيمن .. شايف واحد بيبص على الماوس مفيش مشكلة المهم يعرف يطبق) اختر الأمر Insert Comment أي إدراج تعليق ، ممكن تلاقي كلام امسحه وخلي التعليق فاضي ، وأخيراً ضع المسار اللي نسخته من شوية عن طريق Ctrl + V أي لصق المنسوخ .. لحد هنا بس خلاص الخطوة التالية : روح اعمل كليك يمين على اسم ورقة العمل النشطة اللي فيها الخلية الهدف G7 المطلوب تشغيل الملف الصوتي عند تحديدها كليك يمين على اسم ورقة العمل ثم اختر الأمر View Code والصق الكود التالي في حدث ورقة العمل Private Sub Worksheet_SelectionChange(ByVal Target As Range) PlaySoundNotesInExcel (Target.Address) End Sub سؤال أخير . هل العمل سيكون على خلية واحدة فقط ؟؟ الإجابة : لا ..براحتك ...كل ما عليك بعد كدا لو عايز تشغل الملف الصوتي أو أي ملف صوتي آخر ..إنك تاخد المسار وتروح للخلية وتدرج تعليق وفي التعليق تضع مسار الملف الصوتي المراد تشغيله وبس خلاص أرجو أن يكون الشرح سهل وبسيط وسلس ... ويكون التطبيق فيه مشاكل (أيوا فيه مشاكل عشان يكون فيه استفسارات ونتعلم) دمتم على طاعة الله كان معكم أخوكم أبو البراء من منتدى أوفيسنا حمل الملف من هنا

أخي الحبيب علي العيدروس جزيت خير الجزاء على هذا الإبداع .. ولكن لي تعليق بسيط .. حجم البيانات بالملف كبير جداً مما يجعل التعامل مع البيانات باستخدام الحلقات التكرارية أمر مهلك للغاية في هذه الحالة أعتقد أنه من الأفضل استخدام المصفوفات .. لذا أقدم لك كود يقوم بالأمر (الكود ليس لي بالطبع .. لأنني ما زلت في بداية الطريق في التعامل مع المصفوفات) والكود سيكون أسرع في التعامل مع الملف بهذا الحجم الهائل من البيانات أخي الغالي ياسر جرب الكود التالي Sub Test() Dim Coll As New Collection, CollDummy1 As New Collection, CollDummy2 As New Collection Dim ArrData, ArrIn, ArrOut1(), ArrOut2(), ArrOut3(), ArrOut4(), ArrCalc(), ArrTemp Dim I As Long, P As Long With Sheets("Report") ArrData = .Range("A2:F" & Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row, 2)) End With With Sheets("Rank") ArrIn = .Range("B10:B" & Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row, 10)) End With ReDim ArrOut1(1 To UBound(ArrIn, 1), 1 To 1) ReDim ArrOut2(1 To UBound(ArrIn, 1), 1 To 1) ReDim ArrOut3(1 To UBound(ArrIn, 1), 1 To 1) ReDim ArrOut4(1 To UBound(ArrIn, 1), 1 To 1) ReDim ArrCalc(1 To UBound(ArrData, 1), 1 To 2) On Error Resume Next For I = 1 To UBound(ArrData, 1) Set CollDummy1 = Nothing Set CollDummy2 = Nothing Coll.Add Key:=ArrData(I, 3), Item:=Array(Coll.Count + 1, CollDummy1, CollDummy2) ArrTemp = Coll(ArrData(I, 3)) ArrTemp(1).Add Key:=ArrData(I, 4), Item:=Empty ArrTemp(2).Add Key:=ArrData(I, 1), Item:=Empty P = ArrTemp(0) ArrCalc(P, 1) = ArrCalc(P, 1) + ArrData(I, 6) ArrCalc(P, 2) = ArrCalc(P, 2) + 1 Next I On Error GoTo 0 For I = 1 To UBound(ArrIn, 1) On Error Resume Next ArrTemp = Coll(ArrIn(I, 1)) If Err.Number = 0 Then ArrOut1(I, 1) = ArrCalc(ArrTemp(0), 1) ArrOut2(I, 1) = ArrCalc(ArrTemp(0), 2) ArrOut3(I, 1) = ArrTemp(1).Count ArrOut4(I, 1) = ArrTemp(2).Count End If On Error GoTo 0 Next I Application.ScreenUpdating = False With Sheets("Rank") .Range("D10").Resize(UBound(ArrOut1, 1), 1).Value = ArrOut1 .Range("I10").Resize(UBound(ArrOut2, 1), 1).Value = ArrOut2 .Range("N10").Resize(UBound(ArrOut3, 1), 1).Value = ArrOut3 .Range("S10").Resize(UBound(ArrOut4, 1), 1).Value = ArrOut4 End With Application.ScreenUpdating = True End Sub تقبلوا تحياتي

أخي الكريم اسكندراني الحمد لله أن تم المطلوب على خير والفضل يرجع لله عزوجل ثم أخونا الحبيب علي (العيدروس) جزاه الله عنا خير الجزاء وبارك الله لنا فيه ولا حرمنا منه

أخي الكريم دندن أهلا بك في المنتدى ونورت بين إخوانك ونتمنى لك قضاء أمتع الأوقات مع إخوانك يرجى تغيير اسم الظهور للغة العربية كما يرجى الإطلاع على رابط التوجيهات في الموضوعات المثبتة بالمنتدى اطلع على الملف المرفق فيه ما تريد بإذن الله Gregorian Hijri Dates UserForm.rar

أخي الغالي ياسر الملف غير موجود Sorry, the file link that you requested is not valid. Sign error. يرجى حذف البيانات والإبقاء على 20 صف من البيانات فقط كمثال .. حتى يسهل عليك رفع الملف .. هذا أفضل وأيسر كما يرجى وضع شكل النتائج المتوقعة تقبل تحياتي

أخي الحبيب مختار موضوع رائع ومتميز بارك الله فيك وجزاك الله كل خير تقبل وافر تقديري واحترامي

الأخ الكريم اسكندراني قمت بشرح الكود بشكل سريع عله يفيدك في التعديل كما قمت بتغيير الأرقام بأسماء الأعمدة المشار إليها لتسهيل عملية التعديل عليك حتى تستطيع أن تعدل على ملفك بنفسك Sub Ali_Tr() 'تعريف المتغيرات Dim Shr As Worksheet Dim Wsh As Worksheet Dim Rng As Range Dim LR, II, Rww%, IM, RW Dim MOf, Amel, AGra Dim MOf1, Amel1, AGra1 'تعيين قيمة للمتغير ليساوي ورقة العمل الأولى المطلوب العمل عليها Set Wsh = Sheet1 With Wsh 'تعيين آخر صف به بيانات في ورقة العمل الأولى LR = .Cells(.Rows.Count, 1).End(xlUp).Row 'إلى آخر خلية بها بيانات في العمود الخامس [D3] مسح النطاق بدايةً من الخلية .Range(.Cells(3, "D"), .Cells(LR, "E")).ClearContents End With 'حلقة تكرارية لكل أوراق العمل بالمصنف For Each Shr In ThisWorkbook.Worksheets 'إذا لم يكن اسم ورقة العمل يساوي اسم ورقة العمل الأولى يتم تنفيذ الأسطر التالية 'أي أنه يتم استثناء ورقة العمل الأولى من تلك الأسطر بينما تنفذ الأسطر على بقية الأوراق If Not Shr.Name = Wsh.Name Then 'بدء التعامل مع ورقة العمل التي انطبق عليها الشرط بأنها ليست الورقة الأولى With Shr 'حلقة تكرارية من الصف الثالث إلى آخر صف به بيانات For II = 3 To .Cells(.Rows.Count, 1).End(xlUp).Row 'إذا لم تكن الخلية في العمود الرابع في الصف المحدد في الحلقة التكرارية فارغة 'فإذا لم تكن فارغة يتم تنفيذ الأسطر التالية [D] أي أنه يتم اختبار الخلية في العمود 'أما إذا كانت فارغة يتم الانتقال للصف التالي لاختبار الخلية التالية في العمود الرابع If .Cells(II, "D") <> "" Then 'تعيين قيمة للمتغير ليساوي رقم الصف Rww = .Cells(II, "B").Row 'حلقة تكرارية من الصف الثالث إلى آخر صف به بيانات في الورقة الأولى For IM = 3 To Wsh.Cells(Wsh.Rows.Count, 1).End(xlUp).Row 'إذا كانت الخلية في العمود الثاني في أوراق الموظفين تساوي الخلية في العمود الثاني 'أي أنه يتم المقارنة بين اسم العميل في ورقة الموظف والورقة الأولى فإذا تطابق الاسم 'ينفذ التالي If .Cells(Rww, "B") = Wsh.Cells(IM, "B") Then 'إذا كانت الخلية في العمود الرابع في الورقة الأولى ليست فارغة يتم تنفيذ التالي If Wsh.Cells(IM, "D") = "" Then 'تعيين قيمة للمتغير ليساوي رقم الصف الذي يحوي اسم العميل من الورقة الأولى RW = Wsh.Cells(IM, "B").Row 'الخلية في العمود الرابع في الصف الذي يحوي اسم العميل في الورقة الأولى يساوي الخلية في العمود الرابع في الصف المحدد في الحلقة التكرارية Wsh.Cells(RW, "D") = .Cells(IM, "D") 'الخلية في العمود الخامس في الصف الذي يحوي اسم العميل في الورقة الأولى يساوي اسم ورقة عمل الموظف Wsh.Cells(RW, "E") = .Name 'أما إذا كانت الخلية في العمود الرابع في الأولى تساوي قيمة الخلية في العمود الرابع في ورقة الموظف ElseIf Wsh.Cells(IM, "D") = .Cells(Rww, "D") Then 'تعيين قيمة للمتغير ليساوي قيمة الخلية في العمود الخامس ليحمل اسم الموظف 'تعيين قيمة للمتغير ليساوي قيمة الخلية في العمود الثاني ليحمل اسم العميل MOf1 = .Cells(IM, "E"): Amel1 = .Cells(IM, "B") 'تعيين قيمة للمتغير ليساوي قيمة الخلية في العمود الرابع ليحمل الإجراء 'تعيين قيمة للمتغير ليساوي قيمة الخلية في العمود الخامس في الورقة الأولى ليحمل اسم الموظف AGra1 = .Cells(IM, "D"): MOf = Wsh.Cells(IM, "E") 'تعيين قيمة للمتغير ليساوي قيمة الخلية في العمود الثاني في الورقة الأولى ليحمل اسم العميل 'تعيين قيمة للمتغير ليساوي قيمة الخلية في العمود الرابع في الورقة الأولى ليحمل الإجراء Amel = Wsh.Cells(IM, "B"): AGra = Wsh.Cells(IM, "D") 'إظهار رسالة في حالة التضارب في إدخال البيانات 'أي أنه عند اتخاذ إجراء لعميل عند أكثر من موظف تظهر رسالة تفيد بذلك MsgBox "البند المسمى :" & " " & Amel & " موجود مسبقاً في ورقة : " & " " & MOf & vbCrLf & " بالاجراء :" & " " & AGra & vbNewLine & " " & " وكرر في ورقة :" & " " & .Name & " " & " للعميل : " & Amel1 'التخطي للانتقال لصف جديد GoTo Skipper End If End If Skipper: 'الانتقال للصف التالي في الورقة الأولى Next IM End If 'الانتقال للصف التالي في ورقة الموظف المعنية Next II End With End If 'الانتقال لورقة الموظف التالية Next Shr End Sub أرجو أن ينفعك الأمر تقبل تحياتي

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

ارفق الملف مرة أخرى بعد التعديل للإطلاع عليه ...

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

أخي الكريم محمد ممكن تضع رابط الـdomain المراد فحصه للتجربة عليه؟؟ .. ولو تقدر تضع رابطين أحدهما محجوز والآخر غير محجوز لتجربة بعض الأكواد عليه .. حيث أنني قليل الخبرة في هذا المجال

أخي الكريم هلا أرفقت ملف لتيسير تقديم المساعدة

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

نعم أخي الكريم عبد الله يمكنك أن تطبقه على أي عمود ... الدالة المعرفة في تطبيقها كدوال الإكسيل فمثلا لو كان البيان في الخلية K1 وتريد أن تظهر النتيجة في أي خلية أخرى في ورقة العمل كل ما عليك إلا أن تكتب علامة يساوي يليها اسم الدالة ..هنا اسمها GetNumber كما أسميناها مع العلم أنه يمكنك التعديل لأي اسم تريده (بس لازم تعدل الدالة المعرفة أيضاً) .. المهم بعد علامة يساوي واسم الدالة بتفتح قوس وتكتب الخلية المراد استخراج الرقم منها =GetNumber(K1)

أخي الكريم بكار للأبد أخي الغالي ياسر فتحي المتميز بوركتم على مروركم العطر وجزيتم خيراً .. تقبلا وافر تقديري واحترامي