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

اعرض الملف حساب ضريبة الدمغة علي المرتبات ملف اكسيل لحساب ضريبة الدمغة علي المرتبات الطريقة الاولي بمعادلة الطريقة الثانية بكود صاحب الملف احمد ابوزيزو تمت الاضافه 26 أبر, 2019 الاقسام قسم الإكسيل

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

حبيبنا ،،، هذا هو الاسم الافتراضي الذي يدرجه أكسس عندما ننقر على المفتاح لاختياره في الجدول وطبيعي لن يعمل او بالاصح لن يجده لو ان احدا اجتهد ودخل الى الفهارس وغير الاسم وما دمت اخوي الغالي بهذه الدقة في اختياراتك وطرحك للحلول ، فالكود الذي تفضلت به أنا وانت كلها قاصرة فلو فرضنا وجود اكثر من مفتاح في الجدول فلن يرجع الا باسم واحد فقط وقد وجدت حلا شاملا يستخرج جميع مفاتيح الجدول ان وجدت Dim db As DAO.Database Dim tdf As DAO.TableDef Dim ix As DAO.Index Dim fld As DAO.Field Dim strFields As String Set db = CurrentDb Set tdf = db.TableDefs("tbl1") For Each ix In tdf.Indexes If ix.Primary Then For Each fld In ix.Fields strFields = strFields & "," & fld.Name Next fld Exit For End If Next ix If Len(strFields) > 0 Then strFields = Mid$(strFields, 2) MsgBox strFields

بعد اذن استاذى واخى الحبيب الاستاذ على واثراء للموضوع خل بكود اخر نسخة من هايبر لينك.xlsm

السلام عليكم ورحمة الله وبركاته 🙂 عندما يكون برنامج الاكسس يعمل ، وفجأة بدأ بإعطاء رسائل خطأ وبدون اي تعديل في البرنامج ، او عند عمل تعديل على البرنامج يُغلق الاكسس: . طريقة العمل: سيفتح البرنامج ، ويجب عليك غلقه ، الى ان لا يفتح تلقائيا مرة اخرى. ولكن ، يجب دائما اخذ الاحتياط وعمل نسخة من البرنامج قبل عمل هذه الخطوات. اقدم لكم شرح بسيط عن الموضوع: في الكثير من الاوقات ، لما نعمل الكود ، نقوم بتعديل وتغيير وتضبيط الكود عدة مرات ، ولكن الاكسس في بعض الاحيان يبقى محتفظ بالكود القديم في ذاكرته !! لذلك : 1. اثناء البرمجة ، وبشكل يومي اقوم بتشغيل هذا الملف المرفق ، 2. وقبل تسليم البرنامج الى الزبون ، اقوم بتشغيل الملف للمرة الاخيرة ، واجهز البرنامج لتسليمه الى الزبون وهذا هو الكود المعدل عن النسخة السابقة: Private Sub cmd_Decompile_Click() Dim MSAccPath As String Dim RegKey As String Dim WSHShell 'As Object Dim waitOnReturn As Boolean: waitOnReturn = True ' Get MSACCESS.exe directory from the Registry RegKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\" & _ "CurrentVersion\App Paths\MSACCESS.EXE\Path" Set WSHShell = CreateObject("WScript.Shell") ' Get parent directory MSAccPath = WSHShell.RegRead(RegKey) ' Decompile WSHShell.Run Chr(34) & MSAccPath & "MSACCESS.EXE" & Chr(34) & " " & Chr(34) & Me.str_File_Single & Chr(34) & " /decompile", , waitOnReturn ' compact WSHShell.Run Chr(34) & MSAccPath & "MSACCESS.EXE" & Chr(34) & " " & Chr(34) & Me.str_File_Single & Chr(34) & " /compact", , waitOnReturn ' cmd compile WSHShell.Run Chr(34) & MSAccPath & "MSACCESS.EXE" & Chr(34) & " " & Chr(34) & Me.str_File_Single & Chr(34) & " /cmd compile", , waitOnReturn ' compact WSHShell.Run Chr(34) & MSAccPath & "MSACCESS.EXE" & Chr(34) & " " & Chr(34) & Me.str_File_Single & Chr(34) & " /compact", , waitOnReturn ' Clear shell var Set WSHShell = Nothing End Sub جعفر Decompile_2.zip

السلام عليكم و رحمة الله تعالى و بركاته إن من بين الأشياء الأكثر إرهاقا التي تعيق عمل المبرمجين هو تحديث قاعدة البيانات لدى الزبون فلا تستطيع إعطاءه قاعدة جديدة لأن جميع بياناته مسجلة في تلك القاعدة أما إضافة التحديث يدويا هذا يتطلب منك التنقل إلى الزبون أو الإتصال عن بعد و ربما الزبون لا يملك الأنترنت و الأكثر من ذلك ربما نستطيع التحديث يدويا لقاعدة البيانات و ماشي الحال فرضا هذا الشخص له عدد كبير من النسخ الإحتياطية 60 أو 70 أو أكثر و أراد ربط البرنامج بأحد النسخ الإحتياطية هل يتوجب على المبرمج التنقل له مرة ثانية؟؟ لكل مبرمج طريقته الخاصة بإضافة التحديث لقاعدة بيانات الزبون مع الحفاظ على بياناته سوف أقوم بطرح طريقتي التي أعمل بها و أتمنى من زملائي الأساتذة ممن لديهم طرق أخرى طرحها من أجل إثراء الموضوع. أولا: أنا أضع وحدة نمطية في ملف الواجهة تتحسس لوجود التحديث في قاعدة الخلفية إن لم تجدها فتقوم تلقائيا بإضافة هذا التحديث. الكود يعتمد على أوامر SQL و قد سبق لي أن شرحت هذه الدوال في هذا الموضوع: شرح دوال SQL التحديث هو عبارة عن إضافة جدول جديد أو إضافة حقل لجدول موجود الوحدة النمطية التالية: تقوم بإضافة جدول جديد لقاعدة البيانات اسمه tbl2 و إضافة حقل Age لجدول tbl1 Function edit_db() On Error Resume Next Dim app As Access.Application Dim file_data As String Dim sq As String 'مسار القاعدة file_data = CurrentProject.Path & "\DB.mdb" Set app = CreateObject("Access.Application") app.OpenCurrentDatabase (file_data) app.Visible = False DoCmd.SetWarnings False 'كود إنشاء جدول sq = "CREATE TABLE tbl2_fav ( id COUNTER PRIMARY KEY, name_adm text(50), num integer)" app.DoCmd.RunSQL sq ' كود إضافة حقل لجدول موجود sq = "ALTER TABLE tbl1 ADD COLUMN Age integer" app.DoCmd.RunSQL sq DoCmd.SetWarnings True app.Quit acQuitSaveAll Set app = Nothing MsgBox "تمت العملية بنجاح" End Function ونقوم بإستدعاء هذه الوحدة النمطية عند فتح ملف الواجهة حاول تحذف الجدول tbl2 و الحقل Age من الجدول tbl1 من الملف db و شغل الملف programme ثم أعد فتح ملف db سوف تجد البرنامج قد أضاف الجدول و الحقل تلقائيا. update-db.rar

تفضل هذا المثال: programme.rar

السلام عليكم ملف لحوالي 560 لون مع المعلومات (Hex Code , RGB , MSAccess) اذا اردت استخدام لون في الفورم او ادوات التحكم استخدم الرقم في العمود MSAccess Me.Frame1.BackColor = 5540692 وممكن ادخاله مباشرة اثناء التصميم للاشكال التلقائية RGB للويب Hex Code اثناء معاينة الفورم حرك الماوس في الفورمة ولاحظ ماذا يحدث جعلنا الزر ياتي طوعا حيث انت ليخدمك الخلاصة فيه الكثير من الفوائد ودمتم في حفظ الله المرفق اكسل 2007 اكسل 2003 color.rar

فقط قم بوضع كلمة Table بين قوسين لتصبح [Table] Dim Sql As String Sql = "UPDATE [Table] SET [Table].card = 0;" If MsgBox("هل تريد تفريغ بيانات الحقل", vbYesNo + vbMsgBoxRight, "اخر تنبيه") = vbYes Then DoCmd.SetWarnings (warningsoff) DoCmd.RunSQL (Sql) DoCmd.SetWarnings (warningson) Me.Refresh End If ونفس الشيئ للتاريخ ولكن غير آخر جملة الـ Sql الى ="""" بدل 0 حيث أنه حقل تاريخ وليس رقمى

برنامج حسابات العملاء تسجيل ومتابعة حسابات العملاء عن طريق خمسة حركات مختلفة (فاتورة بيع - مرتد مبيعات - سند قبض - اشعار خصم - اشعار اضافة ) الحل الامثل لضبط ومراجعة الحسابات لتحميل البرنامج اطغط على الرابط التالى http://a7lashare.com//uploads/files/A7lashare-9e7ce016c8.rar مميزات البرنامج تسجيل فاتورة البيع بالقيمة تسجيل فاتورة مرتد المبيعات بالقيمة تسجيل سندات القبض الخاصة بكل عميل تسجيل اشعار خصم - حركة دائنة تسجيل اشعار اضافة - حركة مدينة قاعة بيانات للعملاء تسمل كود العميل واسمة وعنوانة وتليفونة والمنطقة التابع لها لعمل افضل التقارير العمل بـ id مسريل من داخل البرنامج لكل عملية تسجيل بعيدا عن رقم الفاتورة او السند * امكانية المعاينة والتعديل على اى عملية تسجيل تمت بمنتهى السهولة تسجيل اسم المندوب فى كل عملية تسجيل لأعدات التقرير الخاصة بكل مندوب مع العملاء الخاصين به سرعة هائلة فى التسجيل وحفظ البيانات النسخة الاحتياطة هى مجرد كوبى من ملف الاكسيل مع امكانية اخذ نسخة من البيانات المسجلة على ملف اكسيل جديد تصدير التقرير الى ملف خارجى لأرسالها بالميل او لاى غرض اخر بعيد عن البرنامج العمل بأعلى كفائة على الشبكة الداخلية وبأبسط الطرق adminصلاحية لـ 9 مستخدمين والصلاحية الرئيسية لـ admin اسم مستخدم وكلمة سر لكل مستخدم يعرفوا عن طريق تقارير البرنامج كشف حساب لكل عميل تقرير تفصيلى عن كل مندوب تقرير عن حركة معينة بيع - مرتجعات - تحصيلات كشف بأرصدة العملاء كشف تحليل مديونية العملاء موضح فية نسبة التحصيل الى المديونية لكل عميل قائمة تحليل المبيعات موضح بها اجمالى المبيعات والمرتجعات والمتحصلات والخصومات وصافى المسحقات تقرير حركة يومى لمتابعة جميع العمليات المسجلة فى يوم محدد افضل طرق رقابة على المستخدمين وسهولة اكتشاف اخطأ المستخدم فى اثناء عملية التسجيل

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

مشاركة مع اخي عصام ... انظر test_2.rar

اعرض الملف Officena Date Picker صاحب الملف ابا جودى تمت الاضافه 25 أبر, 2019 الاقسام قسم الأكسيس

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

هو انا مش فاهم حاجة بس شوف كده المرفق test.zip

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

تمت التجربة ويعمل بشكل ممتاز

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

اذا تم تغيير تاريخ بنجاح/ سوف اقوم باضافة تغيير الساعة فقطت وضعت تاريخ اذا نجح الامر مع تاريخ اخبرني سوف اعدل فيه ليغير كذلك الساعة

ان لله عباد اختصهم لقضاء حوائج الناس وادعو الله ياستاذ سليم ان تكون منهم

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

@jjafferr سبقتني بالرد يامعلم. كنت اريد ارفاق فنكشن بسيط لارجاع مقبض او اسم الكائن الذي تم الضغط عليه في الفورم. Public Function getXcontrol() Dim ctlCurrentControl As Control Dim strControlName As String Set ctlCurrentControl = Screen.ActiveControl strControlName = ctlCurrentControl.Name MsgBox strControlName End Function @ابا جودى شغل متعوب عليه ومرتب وفقك الله لكل خير عزيزي.

تم العمل بواسط الماكرو انظر الى الصفحة salim من هذا الملف الكود Option Explicit Sub find_FirstAndLast_Time() If ActiveSheet.Name <> "salim" Then Exit Sub Dim objReg As Object Dim Match Dim objMatches As Object Dim a, i, y%: y = 1 Dim arr() Dim m%: m = 2 Range("D2:e5000").ClearContents Set objReg = CreateObject("vbscript.regexp") With objReg .IgnoreCase = False .Global = True .Pattern = "(\d{2}:\d{2})" End With Do Until Range("c" & m) = vbNullString '============================================ Set objMatches = objReg.Execute(Range("c" & m)) If objMatches.Count = 0 Then GoTo Next_m For Each Match In objMatches a = Match.Submatches.Count For i = 0 To a - 1 ReDim Preserve arr(1 To y) arr(y) = Match.Submatches.Item(i) y = y + 1 Next Next Range("D" & m) = arr(1): Range("E" & m) = arr(y - 1) Erase arr: y = 1 Next_m: m = m + 1 '============================================ Loop Set objReg = Nothing End Sub الملف مرفق BASMA.xlsm

لاحظ معي جيدا هذا المثال فرضا لدينا جدول اسمه tbl1 و به حقل اسمه adress و نريد حساب عدد سجلات هذا الجدول بالإعتماد على قيم الحقل adress و وضع النتيجة في t الحالة الأولى (المطابقة التامة لقيمة الحقل): Me.t = DCount("*", "tbl1", "[adress] like '" & Me.g & "'") الثانية (ينتهي بــ): Me.t = DCount("*", "tbl1", "[adress] like '*" & Me.g & "'") الثالثة(يتضمن): Me.t = DCount("*", "tbl1", "[adress] like '*" & Me.g & "*'") الرابعة(يبدأ بــ): Me.t = DCount("*", "tbl1", "[adress] like '" & Me.g & "*'") مع العلم أن me.g هو مربع نص نضع فيه القيمة المراد البحث عنها.

جزاك الله خيرا أستاذنا الغالي نعم type تعود برقم يدل على نوع معين و شكرا أستاذ رمهان على إضافة الدالة TypeName

السلام عليكم يجب حذف العلامة ' من الأمر ChDir ThisWorkbook.Path' حتى يصبح من الشكل ChDir ThisWorkbook.Path أي القيام بـ إعادة تنشيط هذا الأمر داخل الكود... ويكون الكود كاملا بالشكل التالي: Sub Create_Links() Set MyFile = CreateObject("Scripting.FileSystemObject") ChDir ThisWorkbook.Path For Each cell In Range("A2:A" & Range("A60000").End(xlUp).Row) If MyFile.fileexists("الملفات\" & Cells(cell.Row, 1).Value) = False Then Cells(cell.Row, 2).Value = "لا يوجد مستمسك": GoTo 1 ActiveSheet.Hyperlinks.Add Anchor:=Cells(cell.Row, 2), Address:="الملفات\" & Cells(cell.Row, 1).Value, TextToDisplay:="الملفات\" & Cells(cell.Row, 1).Value 1 Next End Sub المصطلح "لا يوجد مستمسك" (الذي وضعته لأحد الإخوة في موضوع مشابه سابق منذ أيام) يمكن تغييره بالمصطلح "لا يوجد ملف بهذا الاسم في المجلد".... بن علية حاجي

السلام عليكم ورحمة الله وبركاته عندما يكون برنامج الاكسس يعمل ، وفجأة بدأ بإعطاء رسائل خطأ وبدون اي تعديل في البرنامج ، او عند عمل تعديل على البرنامج يُغلق الاكسس: . فغالبا المشكلة يمكن حلها بعمل هذه الخطوات: @Echo off Echo decompiling D:\Testing\myDataBase_FE.accdb "C:\Program Files\Microsoft Office\Office14\msaccess.exe" "D:\Testing\myDataBase_FE.accdb" /decompile /cmd shutdown Echo compacting D:\Testing\myDataBase_FE.accdb "C:\Program Files\Microsoft Office\Office14\msaccess.exe" "D:\Testing\myDataBase_FE.accdb" /compact Echo compiling D:\Testing\myDataBase_FE.accdb "C:\Program Files\Microsoft Office\Office14\msaccess.exe" "D:\Testing\myDataBase_FE.accdb" /cmd compile Echo compacting D:\Testing\myDataBase_FE.accdb "C:\Program Files\Microsoft Office\Office14\msaccess.exe" "D:\Testing\myDataBase_FE.accdb" /compact Echo Opening D:\Testing\myDataBase_FE.accdb , and Exiting .bat start "" "C:\Program Files\Microsoft Office\Office14\msaccess.exe" "D:\Testing\myDataBase_FE.accdb" وانا استعمل هذا الملف المرفق ليقوم بالعمل كله: سيفتح البرنامج ، ويجب عليك غلقه ، الى ان لا يفتح تلقائيا مرة اخرى. ولكن ، يجب دائما اخذ الاحتياط وعمل نسخة من البرنامج قبل عمل هذه الخطوات. اقدم لكم شرح بسيط عن الموضوع: في الكثير من الاوقات ، لما نعمل الكود ، نقوم بتعديل وتغيير وتضبيط الكود عدة مرات ، ولكن الاكسس في بعض الاحيان يبقى محتفظ بالكود القديم في ذاكرته !! لذلك : 1. اثناء البرمجة ، وبشكل يومي اقوم بتشغيل هذا الملف المرفق ، 2. وقبل تسليم البرنامج الى الزبون ، اقوم بتشغيل الملف للمرة الاخيرة ، واجهز البرنامج لتسليمه الى الزبون 1Decompile2.zip xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx النسخة رقم 2 ، والتي لا نتعامل مع الكود ، وانما بواجهة فقط 🙂 جعفر

وعليكم السلام 🙂 لو تفتح صفحة الاكواد VBA في برنامجك عن طريق ctrl+G ثم تضغط على الزر F1 على لوحة المفاتيح ، علشان يظهر لك مساعد الاكسس ، ثم تكتب فيه inputbox ، وبيعطيك التفاصيل كاملة 🙂 وكتبت لك المسميات بالانجليزي ، علشان ما ينقلب السطر ويلخبط الامر ، ولا تعرف اوله من آخره !! If InputBox("اتصل بمدير النظام لطلب التعديل على الملف","This is the message Title") = "abc" Then Me.AllowEdits = True End If جعفر

السلام عليكم 🙂 ايش رايك باستعمال الكود التالي ، وحذف احداث النقر الـ 56 الموجودة بالكود 🙂 ' date picker buttons Public Function dxx() DateClick (Right(Screen.ActiveControl.Name, 2)) End Function . . جعفر 1048.Officena DatePicker.mdb.zip

جرب اذا نجح امر نقوم بانشاء نموذج اخر لتغيير الوقت شرط كتابة التاريخ على شكل التالي 2019-04-25 تغيير تاريخ.accdb

تفضل اخى الكريم ومن فضلك لابد من التفاعل والمشاركة الإيجابية مع جميع الأعضاء وأتمنى من الله التوفيق لك دائما هايبر لينك - 1.xlsm

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

بارك الله فيك وأعزك

السلام عليكم جرب المرفق لعل فيه ما تريد... بن علية حاجي hyperlink.rar

بعد اذن اخي مصطفى لا ضرورة لنبحث في العامود صفاً بعد صف عن رقم معين من خلال استعمال الحلقات التكرارية المرهقة للبرنامح (خاصة اذا كان هناك المئات او الالوف من الصفوف) يوجد طريقة اخرى من خلال الدالة المميزة Find التي تنبش المعلومة اينما كانت (وتضع بدها على الجرح مباشرة ---كما يقول المثل) وتملك خاصية ( النبش) مئات المرات دون كلل او ملل الكود Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$G$3" And Target.Count = 1 Then Get_Data End If Application.EnableEvents = True End Sub '+++++++++++++++++++++++++++++++++++++++++++++++++++++++ Sub Get_Data() Dim ws As Worksheet: Set ws = Sheets("البيانات") Dim sh As Worksheet: Set sh = Sheets("البحث") sh.Range("a6").CurrentRegion.Offset(2).ClearContents Dim My_Number: My_Number = sh.Range("g3") Dim But_Rg As Range: Set But_Rg = ws.Range("a2").CurrentRegion.Columns(2) Dim ro%, fixed_ro% Dim m%: m = 7 Dim Search_Rg As Range Set Search_Rg = But_Rg.Find(My_Number) If Not Search_Rg Is Nothing Then ro = Search_Rg.Row: fixed_ro = ro Do sh.Cells(m, 1).Resize(, 10).Value = ws.Cells(ro, 1).Resize(, 10).Value m = m + 1 Set Search_Rg = But_Rg.FindNext(Search_Rg) ro = Search_Rg.Row If ro = fixed_ro Then Exit Do Loop Else MsgBox "No Data" End If End Sub Search_by Find.xlsm

السلام عليكم أو ربما كان هذا المطلوب لكن باستعمال أعمدة مساعدة (فصل أوقات البصمات في خلايا منفصلة)... بن علية حاجي المثال.xls

ربما كان المطلوب BASMA.xls

اقلبه من الاكسس

لكي تفعل ذلك يلزمك صلاحيات مسؤول. وايضا يلزمك اداة خارجية لتفعل ذلك والسبب, لا يمكنك ارغام المستخدمين في تشغيل الاكسس كمسؤول لما قد يلحق الضرر بالكومبيوتر عند استخدام اي كود خاطئ لانك بصلاحيات مسؤول ويمكنك التعديل على جذور النظام. تفضل عدلت لك المرفق وصنعت لك اداة تقوم بتعديل التاريخ والوقت بالاعتماد على ما يتم ادخاله في قاعدة البيانات حسنين ChangeDateTime_SEMO_Pa3x.rar

مزيد المزيد في هذا الملف مع الشرح الوافي UDF_tekrar 8yab .xlsm

استبدل المعادلة الى هذه (Ctrl+Shift+Enter) بعد تغيير اسم الصفحة من شهر 1 الى Month1 =INDEX(Month1!$B$2:$B$218,MATCH((D2&"*"&C2),Month1!$E$2:$E$218&"*"&Month1!$D$2:$D$218,0)) الملف مرفق salim_formula.xlsm

Try This file CODE Sub Give_Date() Dim Start_Date As Date Start_Date = DateSerial([b5], [b4], 1) Dim My_date As Date My_date = Start_Date Dim Dict As Object, x% On Error GoTo Wrong_data Set Dict = CreateObject("Scripting.Dictionary") Range("G8:AH10") = vbNullString With Dict Do Until Month(My_date) <> [b4] If Weekday(My_date) <= 5 Then .Add My_date, "" End If My_date = My_date + 1 x = .Count Loop End With With Range("G8") .Resize(, x) = Dict.keys .Offset(1).Resize(, x) = "Primary" .Offset(, x) = "Total" End With Dict.RemoveAll: Set Dict = Nothing Exit Sub Wrong_data: MsgBox "Wrong_data:" & Chr(10) & _ "Check the value Of $B$4 (Must be an integer between 1 and 12)" & Chr(10) & _ "$B$5 (Must be an integer>1900)", 1048540, "Salim Tell You" End Sub file included Daily Sales.xlsm

في الملف المرفق منك يا استاذ حاتم بعض الاخطاء (يجب تصحيحها كي يعمل الكود بكفاءة) 1- الرقم القومي في البداية موجود وفي العامود الاول ورقم الجلوس في الثاني اما في الشيتات بعد 2Home تنعكس الاية (تم تصحيح الامر بالنسبة لهذه النقطة) 2 _اختلاف في محتوبات الاعمدة بين الصفحات قبل 2Home وبعدها (مثال اللغة العربية في Column H ثم في Column G) في الملف المرفق مني تم حذف 2Home والاستعانة بورقة Fasel (فارغة) تفصل بين الاعدادي والابتدائي والتي يأخذها الاكسل كمرجع لبداية البحث) (تم ادراج عاموين فارغين قبل اللغة العربية في الاعداديات ليصبح كل شيء في موقعه الصحيح) كيفية العمل بالكود 1- الصفحة Fasel يمكن اخفاؤها لانها فقط فاصل بين المرحلتين(اختيارياُ) 4- المرحلة الابتدائية يبدأ لبحث من الصفحة 2 حتى ما قبل الصفحة Fasel 5- المرحلة الاعدادية يبدأ البحث من الصفحة ما بعد Fasel الى نهاية عدد الصفحات 6 - تختار ابتدائي او اعدادي من القائمة المنسدلة في الخلية P2 صفحة Home ثم تكتب الرقم القومي وتضغط الزر الآن لوّن و زخرف كما تشاء الكود Option Explicit Sub find_Studant_Data() Dim sh_ind% sh_ind = Sheets("fasel").Index Dim start_page%, end_page% On Error Resume Next Dim My_St: My_St = Sheets("Home").Cells(2, "L") Dim sh As Worksheet Dim r%, n%, SH_name$ Dim find_rg As Range Dim Adr$, col%: col = 2 Dim k% Dim arr_Even(1 To 13) Dim arr_Odd(1 To 12) Range("My_range") = vbNullString '========================================== arr_Even(1) = 6: arr_Even(2) = 8: arr_Even(3) = 10: arr_Even(4) = 12 arr_Even(5) = 14: arr_Even(6) = 16: arr_Even(7) = 20: arr_Even(8) = 22 arr_Even(9) = 18: arr_Even(10) = 24: arr_Even(11) = 26: arr_Even(12) = 28 arr_Even(13) = 30 For n = 1 To UBound(arr_Even) - 1 arr_Odd(n) = arr_Even(n) + 1 Next '============================= Select Case Sheets("Home").Cells(2, "P") Case "الابتدائى": start_page = 2: end_page = sh_ind - 1 Case Else: start_page = sh_ind + 1: end_page = Sheets.Count End Select For n = start_page To end_page Set find_rg = Sheets(n).Range("B:B").Find(My_St, Lookat:=xlWhole) If Not find_rg Is Nothing Then r = find_rg.Row Adr = find_rg.Address Set sh = Sheets(n) With Sheets("Home") .Cells(2, "F") = Sheets(n).Name & ":" & Adr 'KK .Cells(4, "B") = sh.Range(Adr).Offset(, 2) 'ok .Cells(4, "K") = sh.Range(Adr).Offset(, -1) 'ok .Cells(5, "B") = sh.Range(Adr).Offset(, 1) 'ok .Cells(5, "K") = sh.Range(Adr) .Cells(3, "A") = Sheets(n).Cells(1, "G") & " " & .Cells(6, "c") '===================================== For k = LBound(arr_Even) To UBound(arr_Even) .Cells(12, col) = sh.Range(Adr).Offset(, arr_Even(k)) col = col + 1 Next col = 2 For k = LBound(arr_Odd) To UBound(arr_Odd) .Cells(13, col) = sh.Range(Adr).Offset(, arr_Odd(k)) col = col + 1 Next '============================= End With Exit For End If Next If r = 0 Then MsgBox "Not Found" & Chr(10) & _ "The Number: " & My_St & " Does't Exists", 64, "Salim Tell You" Erase arr_Even: Erase arr_Odd End Sub الملف Super_notes.xlsm

السلام عليكم تستطيع دائما تفكيك اي معادلة لفهمها لاحظ أن نظام الجهاز عندي يضع بالمعادلة علامة (,) بدلا من (;) المعادلة السابقة بعد تفكيكها تكون كالتالي =IFERROR(A,) حيث نستعيض بالمعامل A عن المعادلة SUMPRODUCT((INDEX(ACH.!$B$3:$AP$9999,MATCH(A3,ACH.!$A$3:$A$9999,),)>0)*COUNTIF(INDEX(IP!$C$4:$N$44,,IFERROR(MATCH(C3,IP!$E$2:$N$2,)+2,MATCH(E3,IP!$C$3:$D$3,))),ACH.!$B$1:$AP$1)) ومعني المعادلة الأولي أن في حالة حدوث خطأ من المعادلة A فلا تكتب النتيجة خطأ والآن إلي المعادلة A بنفس الطريقة نبسطها كالتالي A= SUMPRODUCT(B*C) حيث B=(INDEX(ACH.!$B$3:$AP$9999,MATCH(A3,ACH.!$A$3:$A$9999,),)>0) ، C=COUNTIF(INDEX(IP!$C$4:$N$44,,IFERROR(MATCH(C3,IP!$E$2:$N$2,)+2,MATCH(E3,IP!$C$3:$D$3,))),ACH.!$B$1:$AP$1) ومعني ذلك ببساطة أن A تساوي حاصل ضرب مصفوفتين B,C مشروطتين والمصفوفة B هي أيضا يمكن تبسيطها هكذا B=(INDEX(B1,B2,)>0) حيث B1 هي المجال ACH.!$B$3:$AP$9999 ، B2 هي المعامل الناتج عن MATCH(A3,ACH.!$A$3:$A$9999,) و لإيجاد المعامل B2 نذهب للورقة ACH في المجال A3:A9999 والذي يبدأ بالخلية A3 لتبحث عن كود العميل والموجود بالخلية A3 بالورقة QSC ، إذن ستجد أنه في الصف الثامن (إذا بدأت العد من الخلية A3 ) أي أن : الجزء الأخير من المصفوفة B والذي أسميناه B2 سيأتي بالرقم 8 إذن المصفوفة B هي عنصر ناتج من المجال B1 (أي المجال B3:AP9999 في الورقة ACH) وهو العنصر الثامن وحيث أن رقم العمود لم يذكر فيكون الناتج هو كامل الصف الثامن من المجال B3:AP9999 في الورقة ACH وبما أن وحيث المجال B3:AP9999 يحتوي علي 41 عمود من (B) إلي (AP) إذن نتوقع أن يكون العنصر الثامن هذا هو محتوي 41 خلية وبالرجوع لها تجدها (1 , 0 , 1 , 0 , 1 , 1 , 0 , 6.25 , 1 , 2 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 1 , 1 , 0 , 1 , 0 , 0 , 0 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0) بالترتيب حيث يعتبر الخلايا الفارغة أصفار باقي معني أخير بالمصفوفة B وهي مقارنة العناصر الناتجة بالرقم 0 (حيث آخر مقطع منها هو >0) فالناتج النهائي لها سيكون 41 عنصرا كل منها يحتوي علي 1 إذا كان الأصلي أكبر من 0 ويحتوي علي 0 إذا كان الأصلي ليس أكبر من 0 الناتج النهائي لها سيكون هكذا (1 , , 1 , , 1 , 1 , , 1 , 1 , 1 , 1 , , , , , , , , , , , , , 1 , 1 , , 1 , , , , , 1 , , , , , , , , , ) والمعني الطبيعي لهذا هو جعل الإكسل ينتقي عدد المرات (الأصناف) التي أخذها هذا العميل والآن : المصفوفة C هي ..... هكذا بنفس الوسيلة تجد أنها أيضا تنتج 41 عنصرا من الورقة الأخيرة IP وهذه العناصر رأسية (SKU CODE) ولابد أن تتساوي في العدد مع عناصر المصفوفة الأولي أي 41 عنصرا حقيقة أنا لا أعلم ماذا يعني SKU CODE ولكن تقاطع المصفوفتين سينتج 1 عند التقاطعات المملؤة أي التي بها 1 في المصفوفتين أعتقد أن المعني لهذا هو جعل الإكسل ينتقي عدد المرات (الأصناف) التي أخذها هذا العميل وفي نفس الوقت تتطابق مع هذا ال SKU CODE

السلام عليكم ورحمة الله اليك هذا الملف ربما يكون المطلوب time.rar

اليك ما طلبت /عسى ان ينال اعجابك اضغط اعجبني جمع تراكمي.rar

ما رأيكم بهذا الكود ليعمل المطلوب (مقتبس من الاستاذ العبقري عبدالله باقشير) جمع تراكمي.rar

بعد اذن أخى الحبيب / محمد أبو البراء وأخى الحبيب / حمادة عمر هذا هو تصورى وفهمى للفكرة جمع القيم التى يتم ادخالها فى نفس الخلية Private Sub Worksheet_Change(ByVal Target As Range) Static x If Target.Address = [A1].Address Then Application.EnableEvents = False x = x + Target.Value Target = x Application.EnableEvents = True End If End Sub جمع عدة قيم فى خليه واحدة.rar

الروابط معطلة ياخوك