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

السّلام عليكم و رحمة الله و بركاته قمّة الفرح و منتهى السّعادة و أنا أطرق باب بيتي التعليمي " أوفيسنا " .. حامِلاً معي حقيبة أكوادي .. ومن ضمنها " الوابْ بْروصرْ " من محرّر الأكواد ومن خلال " صندوق الأدوات " إضغط على السّهم ..كليك يمين ..أدوات إضافية ثم من خلال القائمة المنسدلة .. قم يالتأشير على خانة " الوابْ بْروصرْ "..مثلما بالصّور المرقمّة بالتّرتيب : وها قد أصبح لديك الآن على اليوزرفورم كائن يسمّى " الوابْ بْروصرْ " قمْ بإضافة هذا المولود الجديد على اليوزرفورم كإضافة أي كائن آخر مثله مثل الليبل أو التاكست-ليست-كومبو بوكس من حيث الحجم كالتّكبير أو التّصغير .. و إذا كنت مرهقًا ..لا عليك .. فقط بالضغط على هذا " الوابْ بْروصرْ " في هذا الملف المرفق رقم 1 .. ثم نسخ و لصق بملفك الشخصي .. مع نقل الأكواد طبعًا .. و التّغيير في العبارة أو العبارات التي تودّ إظهارها على الشّريط المتحرّك قد يتساءل أحد منّا ولو بنفسه .. وهل نحن بحاجة بأن تعرّفنا على هذا " الوابْ بْروصرْ " يا عبد العزيز البسكري ..!!؟؟ و سأجيب بكل بساطة .. لا .. طبعًا .. أنا لا أتكلم بهذا الموضوع عن الطّائرة ..و إنّما قصدتُ جناحَ الطائرة المفقود .. وهو ظهور الشّريط المتحرّك من اليمين لليسار بشكل يواكب لغتنا الأم .. اللّغة العربية .. و نمنحُها أسمى معانيها وضعتُ ملفيْن مرفقيْن ..للمقارنة بينهما و ستلاحظون أنّ التّغيير وقع فقط بجزئية تغيير الاتّجاه .. أساتذتي الأفاضل قد يكون الموضوع بسيطًا لكن عسى أن ينتفع به المبتدئون أمثالي و السّلام عليكم و رحمة الله و بركاته خالص إحتراماتي الواب بروصر يمين يسار.rar

سادسا :- اجبار المستخدم على الاختيار من الكمبوبوكس يوجد طريقتين الطريقه الاولى :- هى استخدام الخاصيه Style اثناء شرحنا لخصائص الكمبوبوكس فى مرحلة التصميم تكلمنا عن الخاصيه Style ودا نسخ الجزئيه الخاصه بالخاصيه Style من شروحتنا السابقه الخاصيه ( Style ):- وهى بنظرى من اهم الخصائص للكمبوبوكس زى ما احنا عارفين لفتح القائمة الخاصه بالكمبوبوكس للاختيار منها لابد من الضغط على السهم لتفتح القائمه ولكن هذه الخاصيه تتيح للمستخدم التحكم فى وقت فتح القائمة الخاصه بالكمبوبوكس فلها خيارين الخيار الاول Fm StyleDropDown Combo - 0 :- هو الافتراضى لابد من الضغظ على السهم لفتح القائمة كما تتيح للمستخدم كتابة اى شئ بالكمبوبوكس غير موجود بالقائمه بمعنى لا تلزم المستخدم من الخيار من القائمة والخيار الثانى Fm StyleDropDown List - 2 : -هو فتح القائمة من خلال الضغط على السهم او بمجرد وقوف مؤشر الماوس على الكمبوبوكس وكمان ميزة ثالته وهى مهمه جدا هو انه لا يمكن للمستخدم كتابة اى شئ فى الكمبوبوكس يعنى كانك عامل خاصيه حمايه للكمبوبوكس ولا سبيل امام المستخدم الا من الاختيار من القائمه -------------------------------------------------------------------------------------------- الطريقه الثانية :- استخدام الخاصيه MatchFound عايزين نعمل كود يقوم باختبار قيمة الكمبوبوكس هل هى موجوده بالقائمه او لا ؟ لو الكمبوبوكس التطابق مع القائمة = خطأ نفذ الكمبوبوكس فارغ ( دا شرح الكود كدا بالبلدى وحنا قاعدين على المصطبه) لتحويل الكلام اللى بالبلدى ده الى لغة البرمجه تابع معايا لو نستبدلها بـ IF (يعنى قاعدة IF) الكمبوبوكس نستبدله باسم الكمبوبوكس المراد العمل عليه وهو على سبيل المثال Me.ComboBox1 التطابق مع القائمه دى الخاصيه Match Found بمجرد كتابة اسم الكمبوبوكس ثم . ثم حرف M ستجد الفيجوال بيسك يعرض لك قائمه للاختيار شاهد الصوره التاليه = خطأ False ( أى ان القيمة المختاره غير موجوده بالقائمه ) نفذ Then الكمبوبوكس فارغ " " شاهد الكود لما نجمع الكلام ده بقى هيكون كالتالى If Me.ComboBox1.MatchFound = False Then ComboBox1 = "" End If طيب ما هو وقت تنفيذ الكود وقت التنفيذ انت اللى بتحدده مثلا ممكن يكون فى حدث تغيير الكمبوبوكس ()Private Sub ComboBox1_Change Private Sub ComboBox1_Change() If Me.ComboBox1.MatchFound = False Then ComboBox1 = "" End If End Sub وبكدا لو عندك قائمه الكمبوبوكس وليكن بها ( مصر & السعودية & السودان & الجزائر ) والمستخدم تجاهل هذه القائمة وراح يكتب تونس بمجرد بس كتابة حرف ت سوف يقوم الكود بالعمل مش هيلاقى دوله فى القائمة تبدأ بحرف ت اذن تحقق شرط عدم التطابق فهيقوم بمسح حرف ت ممكن واحد يفتكر فى عفريت مسح الحرف يعنى كل ما تكتب شئ غير موجود بالقائمه هتلاقيه بيتمسح فورا ----------------------- ممكن نكتب الكود فى وقت حدث الخروج من الكمبوبوكس Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) If Me.ComboBox1.MatchFound = False Then ComboBox1 = "" End If End Sub يعنى المستخدم بمجرد ما يكتب تونس ويضغط انتر للانتقال الى عنصر اخر على الفورم هتلاقى الكود بيتنفذ ويمسك المستخدم من قفاه ويقوله تعالى تونس غير موجوده فى قائمة الكمبوبوكس وهيمسح تونس يعنى كأن المستخدم مكتبش اى حاجه ومازل الكمبوبوكس قيمته فارغه ممكن المستخدم يتجنن هو ايه اللى بيحصل هو ليه كل ما اكتب تونس يتم مسحها هو فى عفريت ؟؟ ما عفريت الا بنى ادم فعلشان نريحه نظهر له رساله تفيد بانه يجب الاختيار من القائمه Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) If Me.ComboBox1.MatchFound = False Then ComboBox1 = "" MsgBox " الرجاء الاختيار من القائمة", vbCritical, "خطأ" End If End Sub قمنا باضافه هذا السطر بالكود قبل نهاية IF MsgBox " الرجاء الاختيار من القائمة", vbCritical, "خطأ" الرساله تتكون من ثلاث اقسام يفصل ما بين كل قسم وقسم علامة , القسم الاول وهو الرساله " الرجاء الاختيار من القائمه" وتم وضعها بين علامتى تنصيص ( وهو قسم اجبارى) القسم الثانى وهو نوع الرساله واظهار علامه لها فكتبنا Vbcritical رساله خطأ ( وهو قسم اختيارى يمكن الاستغناء عنه ) القسم الثالث وهو عنوان الرساله فكتبنا "خطأ" وممكن تكتب اى عنوان كما تشاء ( وهو قسم اختيارى يمكن الاستغناء عنه) فالاساس فى الرساله هو نص الرساله " الرجاء الاختيار من القائمة " MsgBox فأذا ارد اظهار علامه للرساله او عنوان لها قم باضافه القسم الثانى والثالث او استكفى بالقسم الاول اذا حبيت شاهد الرساله عند الاختيار الخاطئ من المستخدم هل يمكن كتابة الكود فى سطر واحد ؟ نعم يمكن ذالك Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) If Me.ComboBox1.MatchFound = False Then: ComboBox1 = "": MsgBox "الرجاء الاختيار من القائمة", vbCritical, "خطأ": Exit Sub End Sub كما تشاهدون الكود انه فى سطر واحد فقط وذالك باستخدام : : ( تكتب من خلال الضغط على شيفت + حرف ك بالعربى ) واستبدلنا عبارة End if بــ Exit Sub -------------------------------------------------------------------------------------------------------------------- الحمد لله انتهينا من شروحات الكمبوبوكس والى لقاء اخر من حلقات سلسلة علمنى كيف اصطاد ان شاء الله هيكون عن الـــ Frame انتظرونا تقبلوا تحياتى

السلام عليكم ورحمة الله وبركاته أحبائى وأساتذتى وأعضاء هذا الصرح العلمى الهائل الذى مهما قدمت له لن أوفيه حقه فيما تعلمت منه الفترة الماضية وبعد قدمت من قبل موضوع بعنوان معادلة بحث جميلة جدا على الرابط ولكن بالمعادلات اليوم أقدم لكم نفس الفكرة ولكن بالأكواد الأكواد المستخدمة الكود الأول فى حدث الشييت : Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Cells(2, 2)) Is Nothing Then: names_by_letters End Sub والكود الثانى يوضع ب Module Sub names_by_letters() Dim myRange As Range Dim i As Integer Dim x As Range i = 2 lr = Cells(Rows.Count, 1).End(xlUp).Row Range("c2:c" & lr).ClearContents Set myRange = Range("a2:a" & lr) For Each x In myRange If Mid(x, 1, 1) = [b2] Then Cells(i, 3).Value = x i = i + 1 End If Next x End Sub أرجوا أن يستفاد منه الجميع والله ولى التوفيق Find By VBA Code.rar

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

أخى أبا عبدالرحمن جرب هذا الملف قد يقيدك Test .rar

أو يمكن استخدام المعادلة بهذا الشكل =(C1-(A1+B1))*LOOKUP(SUM(A1:B1),{0,250,500,1000},{6,6.5,7,0}%)

أخى ليمونة جرب الملف التالى ملحوظة 1 يتم ادخال التاريخ فى الخلية U5 تم اضافة معادلة ترقيم من الخلية A6 الى A31 للحصول على ترقيم سليم قبل وبعد الفلترة ملحوظة 2 : لكى يعمل الكود يجب أن تكون مكتبة الورد نشطة لديك يكون ذلك من خلال فتح الفيجوال بيزك و من تبويب Tools اختر References ثم المكتبة Microsoft Word 12.0 Object Library ( الرقم يختلف حسب اصدار الأفيس ) ثم OK Excel Range To Word V 1.rar

السلام عليكم ورحمة الله وبركاته إخواني الأحباب في المنتدى الغالي هل فكرت يوماً ؟ إذاً أنت موجود .. لأن الحكمة بتقول : أنا أفكر إذاً أنا موجود ، وبتعديل بسيط ممكن نقول : أنا أؤمن بالله إذاً فالله موجود وأنا حي القلب قبل حياة الجسد سرحت اعذروني أقدم لكم اليوم كود جديد ، يقوم الكود كما هو موضح بالعنوان (والموضوع بيبان من عنوانه ..فمحدش يتوه مني عشان أنا متعمد أتوهكم) ..كما هو موضح يقوم الكود بتنفيذ الماكرو أو الإجراء الفرعي عدد معين من المرات ، يمكنك أن تحدد عدد المرات في الملف المرفق قمت بوضع عدد المرات في الخلية C3 ويمكن تغييره بالطبع ، كما يمكن أيضاً (عشان الناس متقولش إني بخلان عليكم بمعلومة) ممكن أن تغير في الكود لتضع عدد مرات التكرار الذي ترغبه داخل الكود ، وذلك من خلال تغيير هذا السطر nTimes = Range("C3").Value إلى هذا السطر nTimes = 3 إذاً فأنت حر في اختيارك لطريقة وضع قيمة المتغير المرتبط بعدد مرات التكرار وإليكم الكود بالشكل الكامل (والكمال لله وحده) 'تعريف المتغير الذي يمثل عداد لعدد مرات تنفيذ الماكرو Dim I As Integer Sub RunMacroNTimes() 'تعريف المتغير الذي يمثل عدد مرات تنفيذ الماكرو Dim nTimes As Integer 'إلغاء خاصية اهتزاز الشاشة Application.ScreenUpdating = False 'وضع القيمة صفر للعداد I = 0 '[C3] ليساوي قيمة الخلية [nTimes] تعيين قيمة للمتغير nTimes = Range("C3").Value 'حلقة تكرارية لتكرار تنفيذ الماكرو طبقاً لقيمة الخلية Do While I < nTimes 'زيادة قيمة العداد بمقدار واحد في كل حلقة تكرارية I = I + 1 'استدعاء الماكرو المراد تنفيذه Call Test 'الانتقال داخل الحلقة التكرارية إلى أن تساوي قيمة العداد قيمة الخلية Loop 'إظهار رسالة تفيد بعدد مرات تنفيذ الماكرو MsgBox "تم تنفيذ الماكرو " & I & " مرات" 'إعادة تفعيل خاصية اهتزاز الشاشة Application.ScreenUpdating = True End Sub Sub Test() MsgBox "مرحباً بكم إخواني .. الترحيب رقم " & I End Sub وعشان خاطر عيون حبايبي اللي زعلانين مني (وهما عارفين مين .. وكل لبيب بالإشارة يفهم .. ومش عايز حد يكون ساخـ (هـ) ـــر مني) قمت بشرح أسطر الكود للاستفادة منه في أكواد أخرى كما أقدم لكم ملف مرفق للإطلاع عليه (ودا عشان الناس الكسلانة .. شايف مختار بيحمل الملف المرفق .. لا إنت لا إنت طبقه بنفسك) وأخيراً تقبلوا تحياتي ودمتم في رعاية الله Run Macro Number Of Times YasserKhalil.rar

الله عليك يا أ / ياسر كود أكثر من رائع أخى الحبيب تسلم يمينك ومرفق أيضا المرفق الأول للحل بدون كماية VBA بعد إذنك يا أ / ياسر فرز المكرر بإجمالى مبيعاته مرتب أبجديا.rar

أخي الكريم نور وحيد جرب الكود التالي عله يفي بالغرض Sub Summary() Dim I As Long, J As Long, M As Long, N As Long, LR As Long, V, ZUM Dim C As Collection Set C = New Collection Application.ScreenUpdating = False On Error Resume Next For I = 3 To Rows.Count V = Cells(I, 1).Value If V = "" Then N = I - 1 Exit For End If C.Add V, CStr(V) Next I On Error GoTo 0 M = 3 For I = 1 To C.Count Cells(M, 5) = C.Item(I) ZUM = 0 For J = 3 To N If Cells(J, 1).Value = Cells(M, 5).Value Then ZUM = ZUM + Cells(J, 2).Value End If Next J Cells(M, 6).Value = ZUM M = M + 1 Next I LR = Range("E" & Rows.Count).End(xlUp).Row Range("E3:F" & LR).Sort Key1:=Range("E1:E" & LR), Order1:=xlAscending, Header:=xlNo Application.ScreenUpdating = True End Sub وإليك الملف المرفق الخاص بك Unique Items With SUM & Sort YasserKhalil.rar

أثراءً للموضوع جرب هذه المعادلة =(C1-(A1+B1))*VLOOKUP(A1+B1,{0,0.6;250,0.65;500,0.7},2)

السلام عليكم ورحمة الله وبركاته أسعد الله أوقاتكم جميعا وكنتم جميعا فى أحسن حال أتقدم إليكم اليوم بمعادلة جميلة جدا جدا تقوم بعمل بحث فى عمود عن أول حرف عن طرق وضع الحرف المراد إظهار النتائج التى تبدأ بهذا الحرف فى خلية ما فيظهر فى العمود المقابل كل الاسماء التى تبدأ بهذا الحرف المعادلة معادلة صفيف يعنى الضغط على Ctrl+Shift-Enter وليس Enter {=IFERROR((IF(ROW()=2;INDIRECT("$A$"&(MATCH(1;(((--($B$2=LEFT($A$1:$A$100;1)))));0)));((INDIRECT("$A$"&(MATCH(1;(((--($B$2=LEFT(INDIRECT(IF(C1="";"";"$A$"&(MATCH(C1;$A$1:$A$101;0)+1))&":$A$100");1)))));0))+(MATCH(C1;$A$1:$A$101;0)))))));" ")} مرفق ملف به المعادلة والتنفيذ أرجوا من الله العلى القدير ان يستفاد منه الجميع Find.rar

=(C1-(A1+B1))*IF(SUM(A1:B1)<250,6%,IF(AND(SUM(A1:B1)>=250,SUM(A1:B1)<500),6.5%,IF(AND(SUM(A1:B1)>=500,SUM(A1:B1)<1000),7%))) جرب المعادلة بهذا الشكل

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

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

السلام عليكم اخي الكريم ياسر فتحي الصبر الصبر ان شاء الله خير رغم قراءتي لطلبك سابقاً الا اني لم اوفق لفكرهعمليه تخدم ملفك السبب كبر حجم البيانات ان شاء الله لي محاوله ان وفقت سوف ارفقه تحياتي

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

أخي ابو عمر جرب الملف التالي Search_by any_letters.zip

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

السلام عليكم ورحمة الله وبركاته اخوتى وأحبابى فى المنتدى بناء على طلب أخينا سعد عايد فى موضوعى الماضى العمليات الحسابية الأربعة بمجرد المرور بالماوس فوق خلية http://www.officena.net/ib/topic/64689-%D8%A7%D9%84%D8%B9%D9%85%D9%84%D9%8A%D8%A7%D8%AA-%D8%A7%D9%84%D8%AD%D8%B3%D8%A7%D8%A8%D9%8A%D8%A9-%D8%A7%D9%84%D8%A3%D8%B1%D8%A8%D8%B9%D8%A9-%D8%A8%D9%85%D8%AC%D8%B1%D8%AF-%D8%A7%D9%84%D9%85%D8%B1%D9%88%D8%B1-%D8%A8%D8%A7%D9%84%D9%85%D8%A7%D9%88%D8%B3-%D9%81%D9%88%D9%82-%D8%AE%D9%84%D9%8A%D8%A9/ أقدم لكم طريقة اظهار واخفاء الفورم بالماوس مش بالـ الأكواد المستعمله بسيطة . تفضلوا المرفق ولا تنسونا فى دعائكم تقبل الله منا ومنكم صالح الأعمال اظهار واخفاء الفورم بالماوس .rar

السلام عليكم اضن الكثير منا يعلم ماهي الوظائف الإضافيه في الاكسل ومدى اهميتها في اختصار الكثير من الوقت للعمل على روتين معين لأكثر من مصنف انا سأطرح لكم الفكرة والتطبيق والاليه التي استخدمت بها تلك الوظيفه الإضافية أولاً ماهي الوظائف الإضافيه ؟ كخطوة اولى: توضيح وحفظ الوظيفه - هيا عباره عن ملف اكسل به اكواد او فورم او داله ويحفظ بصيغة "Excel Add-In" في المسار "AppData\Roaming\Microsoft\AddIns" او في اي مجلد تريد يكون موقع له فرضاً سميناها "Aosamh" وعند الحاجه لتلك الوظيفه تقوم بتفعيل الوظيفه كي تستخدمها للملف الذي تعمل عليه الخطوة الثانية: تفعيل الوظيفه ( بعد ان حفظتها بالخطوة الاولى ) -من خيارات الاكسل - الوظائف الإضافية - إدارة الوظائف الإظافيه Excel ( تضغط زر المسمى "إنتقال" ) ومن ثم تحفز الوظيفه . الفكرة كالتالي : تقرير مخزون عبر برنامج محاسبي اصدره الى الاكسل واقوم بعمل بعض التنسيقات والتعديلات عليه بشكل اتوماتيك واستخرج منه اعمدة معينه للعمل عليها غرضي من هذه الطريقة عمل " تقرير لأصناف معينه لعمل خصم عليها بطريقة يدويه" خصم يدخل يدوي ومن ثم اجمالي الفارق بين سعر التكلفه القديم وسعر التكلفه الجديد واجمالي الفارق لكل الاصناف في نهاية التقرير ماتطلب علي استخدامة لأنجز تلك الفكره : 1- تصدير التقرير من البرنامج المحاسبي 2- معرفة بعض الكلمات الاساسيه في التقرير المستخرج من البرنامج المحاسبي ( لمعرفة ان الملف هو مانريده كي نفعل عليه الوظيفة الاضافية) 3- عمل بعض التعديلات على الملف من الغاء دمج بعض الخلايا وحذف بعض الاعمدة التي لااستخدمها للغرض الذي اريده وماسبق ذكرة الـ 3 البنود منها عملتها بظريقه يدوية ومن ثم بالكود كي يقوم بما عملته عند استدعائي للوظيفة ( 2 و 3 ) 4- عمل في بعض الاعمدة معادلات عبر الكود ومنها اجمالي التقرير بعد اضافة القيم اليدويه 5- انشاء فورم بحث للبحث عن الاصناف في التقرير سواء برقم الصنف او مرجعه الاكواد المستخدمة في ملف الوظيفة الإضافية كالتالي : 1- كود حدث فتح ملف الاكسل "Auto_Open" -استخدمناه لكي نفعل كود التحقق من ان الملف المفتوح حالياً هو مانريده "تقرير المخزون" ام لا الكود في حدث فتح المصنف بعد 3 ثواني من فتح المصنف ينفذ الكود المسمى "Action_Abad" Sub Auto_Open() Application.OnTime Now + TimeValue("00:00:03"), "Action_Abad" End Sub هذا كود "Action_Abad" يقوم بتنفيذ الدالة "Check_Work" واذا كان نتيجة الدالة True يعني هو الملف المطلوب دالة "Check_Work" تقوم بالبحث في المصنف هل يوجد كلمة "تقييم المخزون" اذا تحقق الشرط تقوم بالتالي Public Const Trgt As String = "تقييم المخزون" Public Function Check_Work() Dim Rng_Chk For Each Rng_Chk In ActiveWorkbook.ActiveSheet.UsedRange.Cells If Trim(Rng_Chk) Like Trgt Then Bl_Open = True Exit Function End If Next End Function تقوم بإنشاء زر اختصار للكود "Ali_Tk" في تبويب الوظائف الاضافية Sub Action_Abad() '=============== Check_Work '' دالة التحقق من الملف المفتوح حالياً '=============== If Bl_Open = True Then Dim cb As CommandBar Dim ctrl As CommandBarControl On Error Resume Next Application.CommandBars("Tol_Abad").Delete On Error GoTo 0 Set cb = Application.CommandBars.Add(Name:="Tol_Abad") With cb .Visible = True .Position = msoBarTop Set ctrl = .Controls.Add(Type:=msoControlButton) With ctrl .BeginGroup = True .Style = msoButtonIconAndCaption .Caption = "تقرير_خصم" .FaceId = 107 .OnAction = "Ali_Tk" '' الزر يقوم بتشغيل كود عمل التنسيقات وحذف اعمدة من تقرير المخزون .TooltipText = "تقرير خصم لأصناف" End With End With Bl_Open = False End If End Sub وهذا كود "Ali_Tk" الذي يقوم بعمل تنسيقات للتقرير واضافة اعمدة ودوال واستخراج الاعمدة الاساسية في مصفوفة "Arr" Sub Ali_Tk() Dim Arr Dim RR, Mord, On_Rw Dim Rm As Range Dim Rnn As Range, Rmm As Range Dim Rng As Range A_Application False ActiveWorkbook.ActiveSheet.UsedRange.UnMerge Arr = Array("تقييم المخزون", "‏المورد :‏", "‏م‏", "‏رقم الصنف‏", "‏وصف الصنف‏", "‏رقم المرجع‏", "‏إجمالي الكمية‏", "‏السعر‏") For Each RR In ActiveWorkbook.ActiveSheet.UsedRange.Cells For Each Ar In Arr If Trim(RR) Like Trim(Ar) Then Select Case Trim(RR) Case Is = Arr(0) Case Is = Arr(1) RR.Select Lrm = Selection.End(xlToLeft).Column '' إيجاد عمود اسم المورد Mord = CStr(S_Nm_Ali(Cells(RR.Row, Lrm))) '' إســم المورد On_Rw = RR.Row '' أول صف للجدول Case Else If Not RR Is Nothing Then If Rm Is Nothing Then Set Rm = RR Else Set Rm = Union(Rm, RR) End If End If End Select End If Next Next Rm.EntireColumn.Hidden = True Set Rng = Range("A1:AB1") '************************************************************* Rng.SpecialCells(xlCellTypeVisible).EntireColumn.Delete Range("A1:A" & On_Rw).EntireRow.Delete ActiveSheet.UsedRange.EntireColumn.Hidden = False '************************************************************* Range("A:A,B:B").Select Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove '************************************************************* Rows("1:1").RowHeight = 40 Rows("2:2").RowHeight = 28.5 Range("C2") = "تكلفة جديدة" Range("A2") = "الفرق" ActiveSheet.UsedRange.EntireColumn.AutoFit Columns("F:F").ColumnWidth = 11 Columns("E:E").ColumnWidth = 9.14 Columns("G:G").ColumnWidth = 7.57 Columns("G:G").ColumnWidth = 11.57 Columns("G:G").ColumnWidth = 10.71 R = 3 Lr = Cells(Rows.Count, 2).End(xlUp).Row For i = R To Lr Cells(i, 1).Formula = "=IF(RC[2]="""","""",CEILING(IF(RC[2]="""","""",(RC[3]*RC[1])-(RC[3]*RC[2])),1))" Next With Range("A" & Lr + 1) .Formula = "=SUBTOTAL(9," & Range("A3:A" & Lr).Address(0, 0) & ")" .Offset(0, 1).Formula = "=SUBTOTAL(9," & Range("B3:B" & Lr).Address(0, 0) & ")" .Offset(0, 2).Formula = "=SUBTOTAL(9," & Range("C3:C" & Lr).Address(0, 0) & ")" .Offset(0, 3).Formula = "=SUBTOTAL(9," & Range("D3:D" & Lr).Address(0, 0) & ")" End With Range(Cells(3, 1), Cells(Lr + 1, 8)).Borders.Color = 1 Range(Cells(3, 1), Cells(Lr + 1, 8)).RowHeight = 24.75 Range(Cells(3, 1), Cells(Lr + 1, 8)).WrapText = False Columns("A:H").AutoFit Columns("A:D").ColumnWidth = 9 With Range(Cells(3, 1), Cells(Lr + 1, 8)) .HorizontalAlignment = xlRight .VerticalAlignment = xlCenter .Interior.ColorIndex = xlNone With Range("A" & Lr + 1 & ":H" & Lr + 1) .Interior.Color = RGB(252, 228, 214) .Font.ColorIndex = 23 .Font.Bold = True .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With With Range("A2:H2") .Interior.Color = RGB(252, 228, 214) .Offset(-1, 0).Merge .Offset(-1, 0).RowHeight = 40 .Font.ColorIndex = 23 .Font.Bold = True .Borders.Color = 0 .HorizontalAlignment = xlCenter .VerticalAlignment = xlTop End With End With With ActiveSheet.PageSetup .PrintArea = Range(Cells(1, 1), Cells(Lr + 1, 8)).Address .PrintTitleRows = "$1:$2" .PrintTitleColumns = "" .Zoom = 123 .LeftMargin = Application.InchesToPoints(3.93700787401575E-02) .RightMargin = Application.InchesToPoints(3.93700787401575E-02) .TopMargin = Application.InchesToPoints(3.93700787401575E-02) .BottomMargin = Application.InchesToPoints(3.93700787401575E-02) .HeaderMargin = Application.InchesToPoints(3.93700787401575E-02) .FooterMargin = Application.InchesToPoints(3.93700787401575E-02) .CenterHorizontally = True .CenterVertically = False End With Range("A3").Select ActiveWindow.FreezePanes = True ActiveWindow.SmallScroll Down:=12 Range("C3").Select With Range("A1") .Value = "(" & " طلب خصم بضاعة / " & Mord & " / للمؤسسة " & ")" .Font.Name = "Times New Roman" .Font.Size = 14 .Font.Bold = True .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With '===================== Action_Search '' إستدعاء كود إضافة زر اخر في تبويب الوظائف الإضافية _ لإنشاء زر في تبويب الوظائف الإضافية واسمه بحث ليقوم بتنفيذ كود فتح فورم البحث والتعديل '===================== A_Application True End Sub وفي نهاية الكود يستدعي الكود "Action_Search" ليضيف زر اخر في تبويب الوظائف الإضافية واسمه "بحث" لينفذ كود فتح " فورم البحث" Private Sub Action_Search() Dim cb As CommandBar Dim ctrl1 As CommandBarControl Set cb = Application.CommandBars("Tol_Abad") With cb .Position = msoBarTop Set ctrl1 = .Controls.Add(Type:=msoControlButton) With ctrl1 .BeginGroup = True .Style = msoButtonIconAndCaption .Caption = "بحث" .FaceId = 1100 .OnAction = "Show_Ali" .TooltipText = " بحث في بيانات الاصناف للمورد" End With End With '====================== Visbl_Control False '' الذي يقوم بعمل تنسيقات تلافياً لعدم الضغط عليه مره اخرى ' إخفاء زر المسمى تقرير_خصم '============== Action_Prnt '' إستدعاء كود لإضافة زر اخر بإسم طباعه لينفذ كود طباعة التقرير بعد الانتهاء من عمل التعديلات عليه '============= End Sub دالة " Visbl_Control" لتقوم بإخفاء زر " تقرير_خصم " تلافياً لعدم الضغط عليه مره اخرى Function Visbl_Control(Vis As Boolean) Application.CommandBars("Tol_Abad").Controls("تقرير_خصم").Visible = Vis End Function كود فتح فورم البحث المسمى " Show_Ali" Sub Show_Ali() Ali_Search.show 0 End Sub وفي نهاية كود "Action_Search" يستدعي كود المسمى "Action_Prnt" ليقوم بإنشاء زر واسمه "طباعه" لينفذ الكود المسمى "Prnt" Private Sub Action_Prnt() Dim cb As CommandBar Dim C As CommandBarControl Set cb = Application.CommandBars("Tol_Abad") With cb .Position = msoBarTop Set C = .Controls.Add(Type:=msoControlButton) With C .BeginGroup = True .Style = msoButtonIconAndCaption .Caption = "طباعه" .FaceId = 180 .OnAction = "Prnt" .TooltipText = " طباعة النتائج " End With End With End Sub وهذا كود الطباعه المسمى " Prnt" ليطبع التقرير بعد عمل التصفية للصفوف الملونه بلون معين Sub Prnt() With ActiveSheet .Range("A2:H2").Select Selection.AutoFilter Ln = .Cells(.Rows.Count, 2).End(xlUp).Row .Range(Cells(2, 1), Cells(Ln, 8)).AutoFilter Field:=6, Criteria1:=RGB(225, 225, 235), Operator:=xlFilterCellColor If .UsedRange.SpecialCells(xlCellTypeVisible).Count <= 24 Then MsgBox "لايوجد نتائج للطباعه", vbInformation, "" .Range("A2:H2").Select Selection.AutoFilter Exit Sub End If .Range("G2").EntireColumn.Hidden = True .PrintPreview .Range("G2").EntireColumn.Hidden = False .Range("A2:H2").Select Selection.AutoFilter .Range("A2").Select End With End Sub وهذا كود حدث اغلاق المصنف " Auto_close "ليقوم بحذف تبويب الوظائف الإضافية بما فيه من ازرار انشأناها وقت الاستخدام Sub Auto_close() On Error Resume Next Application.CommandBars("Tol_Abad").Delete Application.CommandBars("Benefits Survey Toolbar").Delete On Error GoTo 0 End Sub ماأرجوه من طرحي هذا اخذ فكره عن الوظائف الإضافية وبما يمكنها من استخدام اكواد ومعادلات مستحدثه في اكثر من ملف وقت الاستخدام وافكار ان شاء الله يستفاد منها - مرفق ملف شرح فيديو طريقة العمل - وملف التقرير المستخرج من البرنامج المحاسبي - وملف الاكواد والفورم وهو كوظيفة إضافية لم استطيع ارفاق الملفات حملتها عبر 4Share وهذا رابط المرفقات http://www.4shared.com/rar/x33ci575ba/_online.html والسلام عليكم

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

Sub names_by_letters() Dim myRange As Range Dim i As Integer Dim x As Range i = 2 lr = Cells(Rows.Count, 1).End(xlUp).Row Range("c2:c" & lr).ClearContents Set myRange = Range("a2:a" & lr) For Each x In myRange If UCase(Mid(x, 1, 1)) = [b2] Or LCase(Mid(x, 1, 1)) = [b2] Then Cells(i, 3).Value = x i = i + 1 End If Next x End Sub مشكور أخى ياسر بارك الله فيك اضافة صغيرة لو كان حرف البحث صمول مش هيعمل البحث لذلك يصبح الكود الرئيسى كما سبق تحياتى

السّلام عليكم و رحمة الله و بركاته ما أحلى الرّجوع إل .......ــى أكوادك لا تنتبه لأكواد ياسر خليل أبو البراء .. إذن فأنت غير موجود .. و أنا بصراحة لم أنتبه تسلم الأيادي ..بارك الله فيك أستاذنا القدير جزاك الله خيرًا و زادها بميزان حسناتك فائق إحتراماتي

السّلام عليكم و رحمة الله و بركاته أخي الكريم Mahmoud330 ..معذرة على سوء التجاوب .. وجدت لك إحدى القوائم المنسدلة .. من كنوز هذا الصرح التعليمي الكبير .. جرّبها ربما قد تفي بالغرض قائمة منسدلة بدون تكرار وبدون فراغات.rar

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

تفضل اخي الغالي بدل الملف التنفيذي بالملف دا وجرب Yasser.rar

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

ما اروع الكودان وشكرا لكل من الاستاذ / ياسر خليل ياسر فتحى

السلام عليكم ورحمة الله وبركاته الاستاذ الفاضل يـاسر خليل تقبل احترامي وتقديري وشكري كود رائع ولفتة رائعة من انسان رائع جزاك الله خير ( يسلمووووو ) 1437/01/27 (هـ)

ربما يكون المطلوب my ful_data_validation.zip

تغضل اخي ابو الحسن New Microsoft Excel Worksheet salim.zip

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

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

انطلقت للعالمية أخي عبد العزيز ربنا يوفقك ويزيدك من فضلة

السلام عليكم دون تعليق No comment حسبي الله ونعم الوكيل...

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

http://www.tvquran.com أنشر تؤجر والسلام عليكم

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

أخي الغالي عبد العزيز أخيراً ..أقولها لك أخيراً انتظرتك طويلاً وقد طال انتظاري وها أنت بحمد الله بدأت المشوار والبداية قوية بارك الله فيك وجزاك الله خيراً .. ونصيحتي لك واصل بلا فواصل .. سؤال بقا ع الطاير ..هل يمكن عمل زر أمر للتحكم في الاتجاه أو زر اختيار Check Box بحيث يكون الخيارين في نفس الكود بدلاً من أن يكونا في كودين منفصلين؟

اشكرك استاذى ياسر على اهتمامك ولكن وفقنى الله فى حل المشكلة بأن غيرت السطر الثانى فى الكود Application.Calculation = xlManua من Manual الى automatic

السلام عليكم ورحمة الله وبركاته بدأت تتفوق على نفسك فالى مزيد من التقدم والرقى

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

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

جزاك الله خيراً .. أ/ سليم حاصبيا اسمح لى ان اعرض طريقة اخرى كنت قد عملت عليها اخى الفاضل يمكنك سحب المعادلة الموجودة بالخلية C4 بشيت التقرير يمينا ويسارا وللاسفل كيف تشاء معادلة صفيف بعد كتابتها يتم الضغط على CTRL+SHIFT+ENTER وليس ENTER فقط الحضور والإنصراف.rar

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

يمكن تجاهل المكرر عبر هذا الملف Find Salim without rep.zip

رائـــــــــــــــــــــــــــــــــــــع أخى الحبيب ياسر خليل وربنا يديك طولة العمر وتبقى عدد المشاركات مليون على رأى أ/ مختار

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

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