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

السلام عليكم 🙂 برامج الاكسس ممكن ان يصيبها العطب corruption لعدة اسباب ، وبرامج تصليح العطب يجب ان تكون من ضمن مكتبة برامج المبرمج 🙂 يُعتبر برنامج DataNumen Access Repair من احد البرامج المهمة في اصلاح ملفات الاكسس المعطوبة ، والآن الشركة تعطي النسخة الاحدث 2.9 للإستعمال الشخصي الغير تجاري ، مجانا ، من موقعهم : https://www.datanumen.com/access-repair/ انزلته وجربته ، بس لاحظت ان البرنامج بطيء بالمقارنة مع بعض البرنامج الاخرى ، ولكن لا تنسى أنها نسخة مجانية (للإستعمال الشخصي الغير تجاري) 🙂 جعفر رجاء استعمل رابط الشركة حتى تنزل آخر نسخة هناك ، بينما ارفق هنا النسخة 3 (احتياطا ، اذا غيرت الشركة رأيها لاحقا والغت النسخة المجانية ، فتكون عندنا هنا النسخة المجانية 🙂 ) daccr.zip

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

تفضل اخي العزيز ارجو ان يكون طلبك ملاحظة : تم عمل دالة يتم استدعائها عن طريق زر امر الناتج ويمكن استدعائها بالطريقة التي تحب Root250.rar

السلام عليكم و رحمة الله تعالى و بركاته بعد أن أنهينا الشطر الأول الخاص بالتعامل مع الويب من الأكسس بإستخدام أداة WebBrowser و هذا رابط الموضوع: نبدأ الآن بحول الله تعالى في الشطر الثاني و هو التعامل مع صفحات الويب بدون إستخدام أداة WebBrowser سوف نستخدم في هذا الموضوع طريقتين الأولى التعامل المباشر مع المتصفح Internet Explorer و الثانية بإستخدام سرفر معين الجزء الأول: التعامل المباشر مع المتصفح Internet Explorer في هذا الجزء إن شاء الله سوف نقوم بفتح نسخة من المتصفح Internet Explorer و نرسل لها بيانات أو نستقبل منها. سوف نستخدم مثال الأخ @ابوآمنة للتطبيق عليه بإرسال بيانات لنموذج غوغل من خلال متصفح خارجي: هذا هو الكود: Dim HTMLDoc As HTMLDocument Dim oBrowser As InternetExplorer Dim oHTML_Element As IHTMLElement Dim sURL As String On Error GoTo Err_Clear sURL = "https://docs.google.com/forms/d/e/1FAIpQLSejrVMF2ucvGdzXefD7MeoKze4_8Fn-ir7dHmrAIwduHzBbtg/viewform" Set oBrowser = New InternetExplorer oBrowser.Silent = True oBrowser.Navigate sURL oBrowser.Visible = False Do ' Wait till the Browser is loaded Loop Until oBrowser.ReadyState = READYSTATE_COMPLETE Set HTMLDoc = oBrowser.Document HTMLDoc.getElementsByTagName("input").Item(0).Value = Me.n1 HTMLDoc.getElementsByTagName("input").Item(1).Value = Me.n2 HTMLDoc.getElementsByClassName("appsMaterialWizButtonPaperbuttonLabel quantumWizButtonPaperbuttonLabel exportLabel").Item(0).Click Do ' Wait till the Browser is loaded Loop Until oBrowser.LocationURL <> sURL oBrowser.Quit MsgBox "لقد تم إرسال البيانات بنجاح" Me.n1 = "" Me.n2 = "" Err_Clear: If Err <> 0 Then Err.Clear Resume Next End If شرح الكود: Dim HTMLDoc As HTMLDocument Dim oBrowser As InternetExplorer Dim oHTML_Element As IHTMLElement Dim sURL As String هنا قمنا بتعريف المتغيرات التي نحتاجها sURL = "https://docs.google.com/forms/d/e/1FAIpQLSejrVMF2ucvGdzXefD7MeoKze4_8Fn-ir7dHmrAIwduHzBbtg/viewform" هذا رابط الموقع Set oBrowser = New InternetExplorer إسناد نسخة من جديدة من Internet Explorer للمتغير oBrowser oBrowser.Silent = True oBrowser.Navigate sURL oBrowser.Visible = False السطر الأول هو إيقاف ظهور رسائل الأخطاء من المتصفح السطر الثاني تصفح الرابط sURL السطر الثالث التحكم في إظهاء أو إخفاء المتصفح أثناء العمل عليه Do ' Wait till the Browser is loaded Loop Until oBrowser.ReadyState = READYSTATE_COMPLETE الإنتظار إلى حين تحميل الصفحة HTMLDoc.getElementsByTagName("input").Item(0).Value = Me.n1 HTMLDoc.getElementsByTagName("input").Item(1).Value = Me.n2 إرسال قيم للمربع الأول و الثاني HTMLDoc.getElementsByClassName("appsMaterialWizButtonPaperbuttonLabel quantumWizButtonPaperbuttonLabel exportLabel").Item(0).Click الضغط على زر إرسال Do ' Wait till the Browser is loaded Loop Until oBrowser.LocationURL <> sURL إجراء حلقة دورانية لا يخرج منها إلا عند تغير رابط الصفحة و ذلك عند الضغط على زر الإرسال oBrowser.Quit إغلاق المتصفح بعد إرسال البيانات للتجربة افتح المرفق و ادخل بيانات في المربع الأول و المربع الثاني و اضغط على زر الإرسال و لاحظ ماذا يحدث و للإطلاع على ظهور النتائج ادخل على هذا الرابط: https://docs.google.com/spreadsheets/d/e/2PACX-1vSi73gAAIE9Rv8Ux43jjcvq9SSpzdVzs3M3ZEtehWqqP0pW4NLFLnkX3Iqoc9dYm_cx8vPz9S1465zd/pubhtml ارسال بيانات لنماذج غوغل.rar

شوف هذا الرابط قد يساعدك : https://exceldevelopmentplatform.blogspot.com/search?q=jQuery+ جعفر

هلا والله ابو آمنه 🙂 يا رجال ، جمعت الاشياء من هني وهناك ، مو تصدق 😁 انا اكسس وبس 🙂 جعفر

عليه افضل الصلاه والسلام صدق رسول الله صل الله عليه وسلم اللهم آمين جزاك الله خيرا اخى واستاذى خالد واسعد الله اوقاتكم كلها بذكره ورضوانه وانا يجمعنا ويظلنا يوم لا ظل الا ظله

اضافة لما اشار اليه معلمنا الفاضل @ابوخليل ممكن نعمل جدول يحتوي مثلا على رقم الفاتورة او العقد ووقت وتاريخ الطباعة ويمكن اضافة رقم اليوزر الذي قام بالطباعة ونعمل استعلام الحاق في زر فتح او طباعة التقرير وفي حدث عند الفتح للتقرير نضع شرط اذا كان الرقم اكبر من واحد يكون نسخة بعدد مرات الطباعة واذا كان واحد تكون الفاتورة او العقد بعبارة اصلي او اي عبارة اخرى في المثال المرفق وضعت عبارتي النسخة الاصلية للنسخة الاولة وما يليها تكون نسخة رقم الملف في المرفقات Database1051.accdb

اخي طارق 🙂 فهمنا للطلب ، يسهل علينا الاجابة ، وطلبك ليس بالسهل ولا بالصعب ، ولكننا علشان نساعدك ، لازم نبرمج لهذا الطلب (1. للشبكة الداخلية) ، او ذاك (2. على الانترنت) ، للمواد التي تريد استعمالها ، وعلى الاكسس : واليك الفرق بينهم : 1. الشبكة الداخلية : برنامج جدا عادي ، حسب المواد اللي عندك ، والصفوف ، تضبط مجلداتك ، وعليه ، تقدر يكون عندك نموذج لإدخال المواد (عن طريق الاستاذ مثلا) ، ونموذج قراءة المواد (للطلبة) ، الواجهة والجداول ممكن تكون على الاكسس ، الواجهة على كمبيوتر الطلبة ، والجداول والمواد (المرفقات) يتم حفظها في مجلد المشاركة على السيرفر (او الكمبيوتر الذي به مجلد المشاركة) ، عمل نموذج/نماذج لعرض المرفقات . 2. على الانترنت : برنامج يقرأ من مكان ما من الانترنت ، ولا ينفع السيرفر المحلي الموجود عندك في المكتب حتى ولو عليه SQL Enterprise 2014 ، لأن الاساتذه/الطلبة ما ممكن يتصلوا به من بيوتهم (وهذا هدفك) ، تستطيع جعل الكمبيوتر المحلى سيرفر لقواعد بيانات سيكوال SQL Server والاتصال به محليا وعن بعد ، بإتباعك هذه الخطوات : وسواء اذا اتبعت الخطوات في الرابط اعلاه ، او عملت استضافة في احد مواقع الانترنت ، فبرنامج سيكون على الانترنت ، ولا يمكن لأحد الوصول اليه وادخال المواد (المرفقات) بالطرق التقليدية ، مثل ما عملنا برنامج اكسس عادي لقراءة البيانات ، فيجب ان نعمله هنا كذلك ، طبعا تقدر تعمل واجهات بإستخدام برامج الواجهات مثل php ، Java ، Python ، JavaScript ، CSS / HTML ، او برامج NET. ، وووو ، ولكن هذا خارج منتدى الاكسس ، لرفع المرفقات ، تقدر انك تضمن المرفقات في حقول قاعدة البيانات SQL Server ، او تعمل واجهة خاصة لفعها من برنامجك ، او ترفعها عن طريق FTP ، اما انزالها الى كمبيوتر الطلبة ، فهم محتاج الى رابط هذا المرفق (واللي هي سبب اسئلتي انا والاستاذ صالح من اول مشاركة) 🙂 فالموضوع مو انه ممكن او لا يمكن عمل هذا البرنامج عن طريق الاكسس ، وانما الموضوع هو ان يكون الطريق واضح امامك ، وانك تمتلك الامكانيات اللوجستية والمادية والوقت (والبرمجة هو جزء بسيط من الموضوع) للوصول لهذه الاشياء 🙂 اتمنى هذا الملخص قد شرح لك لماذا اصرارنا على هذه الاسئلة ، وسببها قولك (التدريس عن بعد) ، وفهمي انها على الانترنت : جعفر

وعليكم السلام-الطلب ليس بسيط كما تدعى وان كان بسيطاً لقمت انت بعمله بمفردك وعلى الرغم ان هذا يعتبر مخالفة لقوانين وتعليمات المنتدى من رفع ملف مشروح -فتفضل هذا الملف سيفيدك كثيرا اداره المخازن.xlsm

تفضل اخي العزيز ارجو ان يكون طلبك Root350.rar

بعد اذن الأستاذ الرائد ولإثراء الموضوع تفضل Camtend(1).xlsm

اهلا بك فى المنتدى هناك عدة أكواد يمكنها عمل ذلك , عليك بإختيار الأنسب لك Public Sub PrintOneLine() Dim rng As Range For Each rng In Range(Range("A5"), Cells(Rows.Count, "A").End(xlUp)) With rng.Parent .PageSetup.PrintArea = rng.EntireRow.Address '.PrintOut 'remove the apostrophy .PrintPreview 'Add an appostrophy End With Next rng End Sub وثانى كود Sub PrintOneLine() Dim Rng As Range Dim WorkRng As Range Dim xWs As Worksheet On Error Resume Next xTitleId = "Officena" Set WorkRng = Application.Selection Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8) Set xWs = WorkRng.Parent For Each Rng In WorkRng xWs.PageSetup.PrintArea = Rng.EntireRow.Address xWs.PrintPreview Next End Sub وهذا ثالث واخر كود Sub Printseprete() Dim c As Range For Each c In ActiveSheet.Range("A5:A105") ActiveSheet.PageSetup.PrintArea = c.EntireRow.Address ActiveSheet.PrintOut Next c End Sub Print.xlsm

اتفضل استخدم هذا اذا كان هناك ملف محفوظ من قبل سيخبرك والا سيعمل لك تقرير جديد Dim X As String X = Me.ZTeacher2.Column(1) & ".pdf" If Len(Dir(CurrentProject.Path & "\" & X, vbDirectory)) <> 0 Then MsgBox "هناك ملف محفوظ من قبل" Else DoCmd.OutputTo acOutputReport, "تقرير المصروفات فردي1", "PDFFormat(*.pdf)", CurrentProject.Path & "\" & X End If

وعليكم السلام ورحمة الله وبركاته أخي الجبيب @احمدزمان أشكرك على ردك الطيب بارك الله بكم أما عن تحويل الرقم إلى نجوم في Txtbox يتم من خلال عرض الخصائص خاصية PasswordChar يتم وضع نجمة بالحقل المجاور لها * فتصبح كل الأرقام والحروف التي تضعها على هيئتها والله أعلى وأعلم. والسلام عليكم

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

شاهد هذا الفيديو https://www.youtube.com/watch?v=gHN4yOOIrnE

+1

وعليكم السلام ورحمة الله وبركاته 🙂 شكرا لك اخي صالح على الشرح وبالتفصيل لهذه المواضيح المهمة 🙂 من تجربتي ، فالتصفح من داخل الاكسس عن طريق webbrowser ، والذي يستعمل ieFrame.dll ، والذي هو جزء من الانترنت اكسبلورر Internet Explorer ، لا يحتوي على جميع خواص Internet Explorer الكامل ، فهذا الموضوع سيكون اشمل و أعم 🙂 فانا هنا من المتابعين كذلك ان شاء الله ، وبصمت 🙂 جعفر

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

عَنْ عَبْدِ اللهِ بْنِ عَمْرٍو، أَنَّ رَسُولَ اللهِ صَلَّى اللهُ عَلَيْهِ وَسَلَّمَ، قَالَ: الدُّنْيَا مَتَاعٌ، وَخَيْرُ مَتَاعِ الدُّنْيَا الْمَرْأَةُ الصَّالِحَةُ الله يصلح لنا ولكم

بالضبط هذا ما أريده ولك أحلى عروسه جزاك الله خيرا ..

وعليكم السلام اخى فايز اطلع على المرفق هل هذا ما تريد؟ تقبل تحياتى ly.rar

الله يعافيك والشكر لله سبحانه

مع ان الاستاذ @husamwahab وضع حل متميز عن طريق عمل استعلامين بعد انشاء علاقة رأس باطراف بين الجدولين والنتيجة متميزة ومن باب اثراء الموضوع وتعدد الحلول ممكن الوصول للنتيجة بدون اجراء اي تعديل وباستعلام واحد عن طريق دالة dsum بثلاثة معايير Nz(DSum("[total]";"كتب_الشكر";"[تاريخ_الكتاب]>" & Format([تاريخ اخر علاوة];"\#mm\/dd\/yyyy\#") & "And [تاريخ_الكتاب]<" & Format([تاريخ العلاوة القادمة];"\#mm\/dd\/yyyy\#") & "and [الاسم]='" & [الاسم] & "'");0) تفسير التعبير اجمع عدد كتب الشكر اذا كان تاريخ الكتاب اكبر من تاريح العلاوة وتاريخ الكتاب اصغر من تاريخ العلاوة القادمة واسم الموظف يساوي اسم الموظف وفي حالة عدم التطابق ضع العدد يساوي صفر ايضاح بسبب استخدام اسماء عربية للحقول لا يظهر الكود في المنتدى بشكل صحيح الملف مرفق Database910.accdb

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

طبعا يمكن عمل هذا من خلال هذه المعادلة =VLOOKUP($A2,$M$7:$O$16,MATCH(B$1,$M$6:$O$6,0),0) معادلة vlookup1.xls

عليكم السلام ورحمة الله وبركاته الطريقة هو ان تنشء حقلا رقميا في الجدول تكون قيمته الافتراضية صفر ، وعند كل امر طباعة للتقرير يتم تحديث هذا الحقل + 1 بحيث لو تمت طباعة التقرير للمرة الرابعة يظهر لك في التقرير الرقم 4

السلام عليكم 🙂 رجاء مراجعة موضوع النسخة 2 من هنا : واجهة هذه النسخة: البرنامج يقوم بهذه الخطوات التي يوصي بها المحترفين (كما هو موضح في الصورة اعلاه) ، طريقة العمل: 1. اختار ملف اكسس ، 2. اذا الملف محمي بكلمة سر ، فيمكن كتابته في المربع المخصص ، حيث سيتم حفظه في ذاكرة الكمبيوتر ، والتي يجب عليك ان تدخلها يدويا للقيام بالخطوات 2 و 3 لمرة واحدة ، بينما البرنامج سيدخلها تلقائيا للخطوات التالية ، 3. يجب ان تمسك مفتاح الشفت ، ثم تضغط على زر Decompile ، ولا تترك الزر إلا لما ينتهي البرنامج من عمله ، عندما نرى الخطوات 8 و 9 🙂 هذه النسخة اسرع من النسخة السابقة ، وافضل 🙂 جعفر Decompile_3.zip

شكرا لك جزاك الله خيرا

حسب ما اعرفه ليس هناك دالة بهذا الاسم في الاكسس لكن تقدر تعمل دالة DCount مع شرط لكي توصل الى النتيجة نفترض عندك جدول بالاسم Tbl1 وعندک حقل فیھ باسم MyCur تستخدم الكود هكذا DCount("MyCur", "Tbl1", Len("[MyCur]" & "") > 0)

اهلا ومرحبا استاذ شيفان جزاك الله خيرا

السلام عليكم و رحمة الله وبركاته ممتاز جزاك الله خيرا انا محتاج تحويل الى نجوم في Txtbox اذا امكن جزاك الله خيرا

مع زحمة الشغل لازم نلطف الأجواء لبعضنا .. هههههههههههههه

يا سلام عليك يا معلمنا جعفر بدأت أشك أنك تعرف جميع لغات البرمجة . لكن ما تبي أحد يدري .😄 لكن لا تبخل علينا حنا طلابك .

خالص الشكر على اهتمامك بالرد

خالد ضلميي أين الضغط على الإعجاب لهذه الإجابة الممتازة ؟!!💙

جزاكم الله خيراً أخي الكريم @أحمد يوسف تقبل تحياتي العطرة

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

الصورة لا تنفع للتصحيح اذ لا يمكن ادراج كود على صورة ارفع الملف نفسه

لربط صفحة ويب بقاعدة بيانات تحتاج إلى sql server أو mysql أطلعنا على هذه الفديوهات إن أمكن ذلك

تحياتى جدا لحضرتك اسال الله ان يزيد حضرتك من علمه هذا هو بالفعل المطلوب .....جزاك الله كل خير

جرب المرفق ملاحظة: يجب ان يكون التاريخ في الصفحات من الاصغر الى الاكبر وكذلك يجب ان يكون تنسيق التاريخ هكذا مثلا 02/03/2020 تجميعه.xlsm

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

الحلقة الثامنة: إستدعاء أحداث و دوال في صفحة ويب سوف نتطرق في هذا الدرس إن شاء الله إلى كيفية إستدعاء حدث لعنصر معين أو إستدعاء دالة موجودة في صفحة ويب. لقد قمت بالتعديل على صفحة ويب بإضافة بعض الكائنات و الدوال من أجل تطبيق هذا الدرس. صفحة الويب هذه موجودة مع المرفق كل ما عليك هو وضعها بجانب الملف. 1- إستدعاء حدث بعد التحديث: الكود التالي يقوم بإستدعاء حدث بعد التحديث لمربع تحرير و سرد اسمه mySelect. كما يمكن استخدام هذا الكود مع مربع نص Me.WebBrowser3.Document.getElementById("mySelect").OnChange 2- إستدعاء حدث عند التمرير: الكود التالي يقوم بإستدعاء حدث عند تمرير الماوس على زر أمر اسمه bt2 Me.WebBrowser3.Document.getElementById("bt2").onmouseover 3- إستدعاء حدث عند النقر: الكود التالي يقوم بإستدعاء حدث عند تمرير على زر أمر اسمه bt1 Me.WebBrowser3.Document.getElementById("bt1").OnClick أو Me.WebBrowser3.Document.getElementById("bt1").Click 4- إستدعاء حدث عند التركيز: الكود التالي يقوم بإستدعاء حدث عند التركيز لمربع نص اسمه mytext Me.WebBrowser3.Document.getElementById("mytext").OnFocus و هكذا نستطيع إستدعاء جميع الأحداث بهذه الطريقة 5- إستدعاء دالة بسيطة موجودة داخل صفحة ويب: نستطيع من خلال الكود التالي إستدعاء الدالة myfunction() دالة بسيطة (بدون براميتر) Me.WebBrowser3.Object.Document.parentWindow.execScript ("myFunction();") 6- إستدعاء دالة موجودة داخل صفحة ويب و تمرير البراميتر: نستطيع من خلال الكود التالي إستدعاء الدالة displayDate(a) و نمرر لها البراميتر a Me.WebBrowser3.Object.Document.parentWindow.execScript ("displayDate('salah hommadi');") 7- عرض رسالة تنبيه في أداة التصفح : يمكننا هذا الكود من عرض رسالة تنبيه داخل أداة التصفح. Me.WebBrowser3.Object.Document.parentWindow.execScript ("alert('الحمد لله على كل حال');") webbrowser.rar

او ممكن على اذا كان اسم قسم التفصيل بالعربي Private Sub تفصيل_Format(Cancel As Integer, FormatCount As Integer) End Sub اذا كان اسم قسم التفصيل بالانجليزي Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer) End Sub جعفر

تفضل على الرغم ان هناك اختلاف بين الصورة والملف , فيمكنك استخدام هذه المعادلة =COUNTIF(B4:AF4,TRUE) جدول العصافير.xlsx

فقط يمكنك ببساطة من خلال هذه الصورة

اكتب في اول سطر من الكود محل المشكلة الجملة التالية : on error resume next

كل تاخير وفيه خير استخدمت كود آخر اسرع من السابق الكود: Option Explicit Private Const ContColmn As Integer = 11 '====================================================== '====================================================== Sub kh_m2Report() Dim obj As Object Dim x(), AryList() Dim iKey Dim iTm As Range, Rng As Range Dim LastRow As Long, iCont As Long Dim i As Long, ii As Long, iii As Long Dim c As Integer, m As Integer Dim Md As Double, Dn As Double '============================================ Set obj = CreateObject("Scripting.Dictionary") '============================================ With Cells.Worksheet LastRow = .Cells(Rows.Count, "B").End(xlUp).Row With .Range("B5") .Activate .Resize(1, ContColmn).ClearContents .Offset(1, 0).Resize(LastRow, ContColmn).Clear End With End With '============================================ With Sheets("daily") LastRow = .Cells(Rows.Count, "A").End(xlUp).Row Set Rng = .Range("A4:A" & LastRow) End With '============================================ On Error GoTo kh_ex kh_Application False '============================================ For Each iTm In Rng iKey = Val(iTm.Cells(1, 5)) Md = Val(iTm.Cells(1, 7)) Dn = Val(iTm.Cells(1, 8)) ''''''''''''''''''' If obj.Exists(iKey) Then iii = obj(iKey) '''''''''''''''''' x(2, iii) = Val(x(2, iii)) + Md x(3, iii) = Val(x(3, iii)) + Dn Else ii = ii + 1 ReDim Preserve x(1 To 3, 1 To ii) obj.Add iKey, ii '''''''''''''''''' x(1, ii) = iKey x(2, ii) = Md x(3, ii) = Dn End If Next '============================================ iCont = obj.Count If iCont Then Set Rng = Sheets("code").Range("A2:A350") ReDim AryList(1 To iCont, 1 To ContColmn) For i = 1 To iCont '''''''''''''''''' On Error Resume Next iKey = x(1, i) m = WorksheetFunction.Match(iKey, Rng, 0) If Err Then m = 0: Err.Clear '''''''''''''''''' Md = x(2, i): Dn = x(3, i) AryList(i, 1) = Md AryList(i, 2) = iKey '''''''''''''''''' If m Then For c = 3 To 9 AryList(i, c) = Rng.Cells(m, c - 1) Next End If '''''''''''''''''' AryList(i, 10) = Dn AryList(i, 11) = Md - Dn '''''''''''''''''' Next '============================================ With Range("B5").Resize(iCont, ContColmn) If iCont > 1 Then .Rows(1).AutoFill .Cells, xlFillFormats .Value = AryList .Sort .Columns(2), xlAscending End With ''''''''''''''''''''''''' End If '============================================ kh_ex: kh_Application True '''''''''''''''''' If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear Else MsgBox "تم تحديث الميزان بنجاح ", vbMsgBoxRight, "الحمدلله" End If '''''''''''''''''' Set obj = Nothing Set Rng = Nothing Erase x, AryList '''''''''''''''''' End Sub المرفق 2003-2007 ميزان مراجعة للاخ ريد2.rar