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

بارك الله فيك اخي عبد الباري وأخي سليم ما رأيكما بتلك المعادلة .. =IFERROR(IF(AND(B1>=VALUE(LEFT(A1,FIND("-",A1)-1)),B1<=MID(A1,FIND("-",A1)+1,LEN(A1)))=TRUE,"فى المدى","خارج النطاق"),"")

أخي العزيز / بوب 2016 هذا حل بواسطة الدوال كما طلبت بواسطة أعمدة مساعدة تم تلوينها من أجل معرفتها والشكر موصول لأستاذنا القدير ياسر خليل حفظه الله على الرغم أني أفضل الحل بالكود والخيار لك في ذلك تقبل تحياتي تجربة 02.rar

بعد اذن اخونا العزيز ياسر خليل أبو البراء استبدل السطر Const sSheet As String = "MySheet" 'Sheet Name بهذا Const sSheet As String = "Sheet3" الاخ وائل عزالدين شاهد المرفق فصل الاقسام فى ملفات.rar تعليمات التشغيل لا تقوم بإنشاء فلدر للملفات الملفات المنتجة لم يتم ازالة اي احرف منها فهي بنفس المسميات

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

الأخ الكريمبوب2016 السلام عليكم نظرا لطبيعة اختلاف اعداد الطلبة فى اللجان جرب المرفق التالى نسألكم الدعاء abo_abary_تجربة 02.rar

السلام عليكم بعد إذن السادة الزملاء الافاضل اخى ناصر تفضل ما طلبت " بموديول عادى " Public Function biram(X) N = Int(X) If X > 50 Then result = (X - 50) * 0.006 If X > 250 Then result = 1.2 + (X - 250) * 0.0065 If X > 500 Then result = 2.825 + (X - 500) * 0.007 If X > 1000 Then result = 6.325 + (X - 1000) * 0.0075 If X > 5000 Then result = 36.325 + (X - 5000) * 0.008 If X > 10000 Then result = 76.325 + (X - 10000) * 0.003 biram = result End Function وضع هذه المعادلة بالخلية C1 ثم إسحب لاسفل على اعتبار ان القيمة المعنية بحساب الدمغه العادية بالخلية A1 ثم قارن بين الكود المشار اليه وبين المعادلة المشار اليها حيث تم تصويب المعادلة بمعرفتى وفقا لنص المادة رقم 79 من قانون 111 لسنة 1981 ستجد أن جميع العمليات الحسابية مطابقة =ROUND(biram(A1);1) دائما فى خدمتكم ***** وجزاكم الله خيرا

جرب هذا الملف بالنتسيق الشرطي 11salim.rar

الأخ الكريمahmede السلام عليكم =IF(AND(B1>=VALUE(LEFT(A1;1));B1<=VALUE(MID(A1;FIND("-";A1;1)+1;2)))=TRUE;"فى المدى";"خارج النطاق") جرب المرفق التالى وبه هذه المعادلة لعله يفى بالغرض نسألكم الدعاء @ياسر خليل أبو البراء abo_abary_in_out_range.rar

ربنا يبارك فيك يا فلاحجي وعوداً حميداً .. المنتدى نور بعودتك تقبل وافر تقديري واحترامي

بارك الله فيكم اخوانى عمر الحسينى وياسر ابوالبراء وجعلكم عونا لاخوانكم دائما وسدد الله خطاكم ورزقكم من حيث لاتعلمون

أخي وحبيبي ومعلمي عمر الحسيني ملف رائع ومبدع كالعادة ... بعد مشاركتك الأخيرة قمت بالتعديل مرة أخرى على الكود لأسهل على الأخ السائل المسألة .. قمت بإضافة إنشاء المجلد Ouput إذا لم يكن موجوداً من قبل .. وقمت بحذف الجزء الخاص بتسمية ورقة العمل والذي أتعبني بشدة ... حيث أن هناك رموز خاصة ما أن بعض الأسماء يزيد عن 31 حرف مما يؤدي إلى حدوث مشاكل أحببت أن يكون الكود عام يمكن استخدامه بشكل عام .. لذا أضفت دالة تحذف الرموز الخاصة بالنسبة لتسمية المصنفات ...لابد منها حيث قد تحتوي النصوص الموجودة على رموز خاصة مثل / \ : ؟ * وهي محرمة أن يسمى الملفات بها .. وهذا ما حدث معك بالضبط قم بتجربة ملفك مرة أخرى ولاحظ عدد المصنفات التي تم استخراجها .. ستجدها 32 ملف بينما الكود الخاص بي سيتستخرج 33 ملف .. المصنف المفقود بالنسبة إليك هو A399 وهو بالشكل التالي QMS&HSE : Quality Management System & Health, Safety لاحظ النص وفيه العلامة : ، وطبعاً بسبب استخدام سطر تخطي الخطأ حدث خطأ وتخطى هذا المصنف ولم ينشأ له مصنف .... من ثم ومما سبق شرحه ... تعرف أن البرمجة لا تخص ملف بعينه والأفضل أن نتعامل بشكل عام مع المشكلة لا أن نتعامل مع المشكلة من زاوية واحدة كان من الممكن أن أعالج الكود الذي قدمته باستخدام الدالة Replace ونستبدل علامة : بـ "" لا شيء وتمر المشكلة بسلام ويتم إنشاء الملف بدون مشاكل وتنتهي قضية الموضوع .. ولكني أحب أن أتعامل مع المشكلة بشكل أعم وأشمل ، وأعتقد أنك تقوم بذلك بالفعل وهذا ما يعجبني فيك كثيراً أمر آخر وهو الاستعانة بورقة العمل في تنفيذ المهمة ..هذا أمر لا أستحبه كثيراً وإن فعلت أقوم بالتخلص من المخلفات أي أقوم بحذف الأعمدة التي تم استخدامها أعتذر عن الإطاله في المشاركة ولكن وجبت المناقشة للوصول لأفضل الحلول بالنسبة لورقة العمل التي يتم العمل عليها يتم تغييرها في سطر الكود التالي Const sSheet As String = "MySheet" 'Sheet Name أي قمت بتغيير النص MySheet إلى Sheet3 .. حسب الملف المرفق في المشاركة الأولى وأخيراً إليكم الكود بعد التعديل الأخير Sub Export_Workbooks_Using_Filter() Dim a, I As Long, Dic As Object Dim strDir As String Const colNo As Long = 2 'Column Number Const sSheet As String = "MySheet" 'Sheet Name strDir = ThisWorkbook.Path & "\Output\" Call SpeedUp If Dir(strDir, vbDirectory) = "" Then MkDir strDir Sheets.Add before:=Sheets(1) Set Dic = CreateObject("Scripting.Dictionary") Dic.CompareMOde = 1 With Sheets(sSheet).[A1].CurrentRegion .Columns(colNo).Value = Application.Trim(.Columns(colNo).Value) a = .Value .Parent.AutoFilterMode = False For I = 2 To UBound(a, 1) If Not Dic.exists(a(I, colNo)) And Not IsEmpty(a(I, colNo)) Then Dic(a(I, colNo)) = Empty .AutoFilter colNo, a(I, colNo) .Copy Sheets(1).Cells(1) Sheets(1).Copy With ActiveWorkbook With Sheets(1) .DisplayRightToLeft = False .Columns.AutoFit End With .SaveAs strDir & RemoveSpecial(CStr(a(I, colNo))) & ".xlsx" .Close End With Sheets(1).Cells.Clear .AutoFilter End If Next I End With Sheets(1).Delete Call SpeedDown MsgBox "Done...", 64 End Sub Function RemoveSpecial(sInput As String) As String Dim sSpecialChars As String Dim I As Long sSpecialChars = "\/:*?""<>|" For I = 1 To Len(sSpecialChars) sInput = VBA.Trim(Replace$(sInput, Mid$(sSpecialChars, I, 1), " ")) Next I RemoveSpecial = sInput End Function Function SpeedUp() With Application .Calculation = xlManual .ScreenUpdating = False .DisplayAlerts = False .EnableEvents = False End With End Function Function SpeedDown() With Application .Calculation = xlAutomatic .ScreenUpdating = True .DisplayAlerts = True .EnableEvents = True End With End Function تقبلوا تحياتي

هذه محاولة كما في الصورة : ضع بياناتك في المنطقة الخضراء وسيقوم الأكسل بإيجاد نقطة التقاطع الفكرة بحاجة للتجربة حتى يتم إيجاد الأخطاء وتصحيحها أترك لك م/ هاني تجربة هذه الفكرة وموافاتنا بالنتيجة جرب المرفق Lighting Calculations1.rar

السلام عليكم اسمحوا لي أن أتدخل في الموضوع لاشرح بشي من التفصيل بحسب ما فهمت والمطلوب من المهندس هاني أن يصحح المعلومات التي سأذكرها في هذه المشاركة الجدول الموجود في الملف هو الأساس الذي يتم من خلاله الحساب المعطيات الأربع هي 1 طول الغرفة 2 عرض الغرفة 3 ارتفاع السقف 4 ارتفاع مستوى الإنارة مثال : غرفة طولها 15 متر , وعرضها 2.55 متر , وارتفاع سقفها 4 متر إذن ستكون هذه المعطيات واقعة ضمن النطاق الذي في الصورة أدناه بناء على المعطيات أعلاه فإنه يجب أن يكون ارتفاع مستوى الإنارة داخل الغرفة من 2.7 ألى 2.85 وبهذه الطريقة سوف أحصل على الحرف F ( تقاطع الصف مع العمود ) أخي المهندس هاني : أرجو تصحيح هذه المعلومات

أخي الكريم وائل عز الدين لقد أتعبني ملفك بسبب الرموز الخاصة الموجودة في العمود الثاني .. والحمد لله تغلبت على المشكلة بإزالة الرموز الخاصة أثناء تسمية المصنف أو ورقة العمل قم بإنشاء مجلد في نفس مسار المصنف باسم Output ثم ضع الكود التالي في موديول عادي ثم نفذ الكود .. Sub Export_Workbooks_Using_Filter() Dim A, I As Long, Dic As Object Const colNo As Long = 2 'Column Number Const sSheet As String = "MySheet" 'Sheet Name Application.ScreenUpdating = False Application.DisplayAlerts = False Sheets.Add before:=Sheets(1) Set Dic = CreateObject("Scripting.Dictionary") Dic.CompareMode = 1 With Sheets(sSheet).[A1].CurrentRegion .Columns(colNo).Value = Application.Trim(.Columns(colNo).Value) A = .Value .Parent.AutoFilterMode = False For I = 2 To UBound(A, 1) If Not Dic.exists(A(I, colNo)) And Not IsEmpty(A(I, colNo)) Then Dic(A(I, colNo)) = Empty .AutoFilter colNo, A(I, colNo) .Copy Sheets(1).Cells(1) Sheets(1).Copy With ActiveWorkbook With Sheets(1) .Name = AlphaNumericOnly(CStr(A(I, colNo))) .DisplayRightToLeft = False .Columns.AutoFit End With .SaveAs ThisWorkbook.Path & "\Output\" & AlphaNumericOnly(CStr(A(I, colNo))) & ".xlsx" .Close End With Sheets(1).Cells.Clear .AutoFilter End If Next End With With Application Sheets(1).Delete .DisplayAlerts = True .ScreenUpdating = True End With MsgBox "Done...", 64 End Sub Function AlphaNumericOnly(strSource As String) As String Dim I As Integer Dim strResult As String For I = 1 To Len(strSource) Select Case Asc(Mid(strSource, I, 1)) Case 48 To 57, 65 To 90, 97 To 122, 32 strResult = strResult & Mid(strSource, I, 1) End Select Next I If Len(strResult) > 31 Then strResult = Mid(strResult, 1, 31) AlphaNumericOnly = Application.WorksheetFunction.Trim(strResult) End Function تقبل تحياتي

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

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

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

الله يبارك فى عمرك وفى عمر البراء ياأبو البراء والله ليك وحشة وكل عام انتم بخير بمناسبة حلول عيد الاضحى المبارك أهو تغيير وكلنا فى الهوا سوا وان كان الــ Simple فعمنا جوجل ميعرفشى أن ثقافتى وجعانى قصدى ألمانى ههههههههههههههههه أهو تخبيط بس جايب نتيجة ونتيجة كويسة على الاقل مجتشى من احبابنا وفى الاخير هى تجربة ناجحة حتى الان جزاكم الله خيرا وبارك فيكم ***** تقبل وافر تقديرى ياحبيى والله العظيم سبقتنى دائما سباق فى الخير وللخير ولاداعى لرفع ملف جزاكم الله خيرا

اسمح لي أخي الحبيب أبو عبد الرحمن بتعديل طفيف بحيث لو كانت الخلية فارغة يعطي فراغ ، وبدلاً من أن تقوم بعملية التقريب في المعادلة تم إدراجها في الدالة المعرفة Public Function Biram(X) Dim N As Variant, Result As Variant If IsEmpty(X) Then Biram = "": Exit Function N = Int(X) If X > 50 Then Result = (X - 50) * 0.006 If X > 250 Then Result = 1.2 + (X - 250) * 0.0065 If X > 500 Then Result = 2.825 + (X - 500) * 0.007 If X > 1000 Then Result = 6.325 + (X - 1000) * 0.0075 If X > 5000 Then Result = 36.325 + (X - 5000) * 0.008 If X > 10000 Then Result = 76.325 + (X - 10000) * 0.003 If IsNumeric(Result) Then Biram = Round(Result, 2) End Function تقبل تحياتي

الأخ العزيز سليم حاصبيا الأخ العزيزياسر خليل أبو البراء نحاول نبسط الأمور شوية ونجرب المعادلة التالية =IF(VALUE(MID(A1;FIND("-";A1;1)+1;5))>VALUE(LEFT(A1;FIND("-";A1;1)-1));IF(AND(B1>=VALUE(LEFT(A1;FIND("-";A1;1)-1));B1<=VALUE(MID(A1;FIND("-";A1;1)+1;5)))=TRUE;"فى المدى";"خارج النطاق");IF(AND(B1<=VALUE(LEFT(A1;FIND("-";A1;1)-1));B1>=VALUE(MID(A1;FIND("-";A1;1)+1;5)))=TRUE;"فى المدى";"خارج النطاق"))

بارك الله فيك يا أستاذ زدنا من علمك زادك الله من علمه

الاخ سليم شكرا جزيلا تحياتى

أين المرفق أخي الكريم حسين؟

ربما يفيد هذا الملف بدون VBA True_vlookup.rar

السلام عليكم استاذ عبدالفتاح لقد استفدنا من شروحاتك الكثير . الله يجعلها في ميزان حسناتك (آمين يارب) لدي سؤال اذا تكرمت هو كيف اقارن بين عمودين في استعلام اكسس مثل هذه الداله في الاكسيل اريدها في الاستعلام =IF(ISNUMBER(MATCH(B1;A1;0));"موجود";"غير موجود") (المطلوب الكود الذي اكتبه في العمود الجديد"المقارنه") المثال عمود1 عمود2 المقارنه 9999 9999 موجود 9998 9999 غيرموجود ولك جزيل الشكر والتقدير. ؛؛؛؛؛؛؛؛؛؛؛؛

الاخ ياسر خليل أبو البراء ادعو لفاتح الطريق العتب علي النظر الضعيف الاكسيل عند عربي لم الحظ ال 2 من 3 في اللغة العربية الاخ وائل عزالدين المرفق بعد التصحيح فصل الاقسام فى ملفات_2.rar

هذا أجمل وابسط وأيسر ..بارك الله فيك يا سليم

فتح الجداول وجاري التحديث https://play.google.com/store/apps/details?id=com.kmsoft.access_db_viewer

بالظبط ده المطلوب ربنا يعزك كود رائع

من المفترض أن تكون النتيجة "خارج النطاق" في الحالة التي ذكرتها أخي سليم ولكن المعادلة الموجودة تظهر أن رقم 5 في المدى

اخي ياسر العدد 5 ليس موجوداً بين العددين 36 و 52 كما تلاجظ نحن لا نفتش عن 5 كنص بل كقيمة (أظن ان هذا ما يطلبه السائل) مثل اخر ربما يريد ان يبحث عن العدد 41 بين هذين العددين (تكون النتيجة خاطئة)

يمكن استخدام الجملة Select Case .. سأرفق لك ملف حاول الاستفادة منه وتطبيق الشروط ومرفق صورة جزء من حلقات افتح الباب لشرح استخدامها Select Case Tutorial ListenData.rar

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

اكتب المدخلات ثم اضغط زر calculation جرب المرفق Lighting Calculations2.rar

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

كل التوفيق والتجاح شكرا على الشرح

بارك الله فيك أخي الغالي أبو علي (راسبوتين سابقاً) وجزيت خيراً على مساهمتك الرائعة وتخمينك الممتاز في الحقيقة أنني لدي من الحلول والتخمينات ما يمكنني أن أطرح مشاركة إيجابية لكني أود أن يلتزم الأعضاء بشيء واحد ولذا ألح عليه دائماً في كل مشاركاتي ، وهو التوضيح أريد أن نرتقي في أسلوب تقديم المشكلة قبل حلها إذ أن أي مشكلة إذا عرفت بشكل جيد تم حلها بنسبة 90 % وبدون جدال في ذلك عموماً لعله خير وإن شاء الله نرتقي ... بالتعاون معاً أخي الكريم محمد بالنسبة لطلبك لا يمكن التعديل في المعادلة نفسها إنما يكون التعديل في الخلايا المرتبطة بالمعادلة ذكرت أنك قمت بعمل معادلة Concatenate والتي تجمع النصوص من الخلايا ولنفترض أن الخليتين A1 و B1 تم عمل دمج للنصوص بينهما وكانت المعادلة في C1 ... لو أردت التعديل في الخلية C1 فهذا مستحيل لأنها معادلة .. أما الحل في هذه الحالة أن تقوم بالتعديل في أحد الخليتين المرتبطتين بالمعادلة أي بالخلايا A1 و B1 ..أرجو أن تكون قد اتضحت الصورة تقبلوا تحياتي

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

بعد اذن اخى الكبير الجليل ا / ياسر اى معادلة تريد تحويلها لقيمة 1- تظليل العمود بالكامل 2- عمل نسخ للعمود 3- ظلل عمود فارغ 4- اعمل Click بزر الماوس الشمال 5- اختار Paste Special 6- اختار من القايمة الى هاتظهر لك اختيار values لو انت محتاجها بكود تعمل دا اتوماتيك فانت لازم ترفق ملف زى ما قال لك اخونا العزيز ا / ياسر

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

عناية الاستاذ المحترم ياسر خليل و الله انا ماحصلت بحياتي اهتمام و احترام مثل اللي بالمنتدى هنا و مثل حضرتك الله يديمك و يكتر من امثالك و من امثال اللي تعبوا بعمل المنتدى لخدمة الجميع الله سبحانه تعالى يعطيكم الصحة و العافية و انا هارفق لحضرتك هنا الشيت بارك الله في حضرتك Workers Attan.- Original-1.rar

دائماً اردد وأقول ان الخلايا المدمجة هي عدو المعادلات حاول تجنبها و ذلك باضافة ارقام (مثلاُ من 27 الى 50) حينها يمكن ايجاد حل عن طريق الكود

الحمد لله أن تم المطلوب على خير أخي الكريم تحيا مصر وربنا يجازيك خير على دعواتك الطيبة المباركة ، ولك بمثلها إن شاء المولى وأي حاجة تحتاجها هنا هتلاقي إخوانك وعيلتك التانية .. تقبل تحياتي

يا اخ ياسر مش عارف كيف اشكرك فأنت انا استاذ ورئيس قسم كبير وحليت لى مشكلة كبيرة اما عن حماية اوراق العمل مش مطلوبة ربنا يعوضك خيرا فى صحتك ويبارك لك ربنا فى اسرتك

كلمة السر saf ..أما حماية أوراق العمل فهذا أمر بسيط جداً وأي حد ممكن يساعدك في هذه النقطة

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

أخي الكريم موريادي قمت بعمل أعمدة مساعدة في الورقة المسماة Report عمود لإدراج الشهور الهجرية فيه .. وعمود لإدراج السنوات .. وفي الخلية I1 معادلة لمعرفة رقم الشهر الهجري ومقارنته أثناء عمل الكود تقوم بالاختيار من القائمة المنسدلة الشهر المطلوب وليكن "شعبان" ثم تختار السنة الهجرية من الخلية المجاورة F2 .. ثم أخيراً انقر على زر الأمر لجلب البيانات من ورقة العمل Data تم استخدام المصفوفات في الأكواد لسرعتها في التعامل مع البيانات الكبيرة Sub Test() 'Author : YasserKhalil 'Release : 29 - 08 - 2016 '------------------------ Dim Ws As Worksheet, Sh As Worksheet Dim Arr, Temp Dim Lr As Long, I As Long, P As Long Dim lMonth As Integer, lYear As Integer Set Ws = Sheets("Data"): Set Sh = Sheets("Report") Lr = WorksheetFunction.CountA(Ws.Columns(2)) lMonth = Sh.Range("I1").Value lYear = Sh.Range("F2").Value Arr = Ws.Range("A2:H" & Lr).Value ReDim Temp(1 To UBound(Arr, 1), 1 To 3) For I = 1 To UBound(Arr, 1) If Month(DHijri(CDate(Arr(I, 5)))) = lMonth And Year(DHijri(CDate(Arr(I, 5)))) = lYear Then Temp(P + 1, 1) = Arr(I, 4) Temp(P + 1, 2) = Arr(I, 5) Temp(P + 1, 3) = Arr(I, 8) P = P + 1 End If Next I Sh.Range("A6:C10000").ClearContents If P > 0 Then Sh.Range("A6").Resize(P, UBound(Temp, 2)).Value = Temp MsgBox "Done...", 64 Else MsgBox "No Data For This Month And This Year", vbExclamation End If End Sub Function DHijri(dtGegDate As Date) As String VBA.Calendar = vbCalHijri DHijri = dtGegDate VBA.Calendar = vbCalGreg End Function أرجو أن يفي هذا بالغرض إن شاء الله تقبل تحياتي Grab Data By Hijri Dates Using Arrays YasserKhalil.rar

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

جرب الملف المرفق ممكن يكون هو المطلوب ARCHIVE_1.rar

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