نجوم المشاركات
Popular Content
Showing content with the highest reputation on 01/24/16 in مشاركات
-
السلام عليكم ورحمة الله وبركاته كنت منذ فترة قدمت لحضراتكم موضوعا بعنوان : إغلاق آلى لملف اكسل إذا ترك بدون استخدام على الرابط التالى : http://www.officena.net/ib/index.php?showtopic=59908 واليوم أعرض على حضراتكم موضوعا شبيها كما يبدو من عنوان الموضوع : كيفية تشغيل كود ( أى كود ) إذا ترك ملف الاكسل بدون استخدام الطريقة : 1- ضع الكود التالى فى حدث الملف Private Sub Workbook_SheetActivate(ByVal Sh As Object) ResetTime ' كود اعادة المدة كلما حدث تنشيط شيت End Sub Private Sub Workbook_SheetCalculate(ByVal Sh As Object) ResetTime ' كود اعادة المدة كلما حدث تغيير فى البيانات End Sub Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) ResetTime ' كود اعادة المدة كلما حدث تغيير فى شيت End Sub ضع الكود التالى بمديول عادى Public MyTime As Date Sub Auto_Open() MyTime = Now + TimeSerial(0, 0, 30) ' بداية عمل الكود بعد فتح الملف Application.OnTime MyTime, "MyMacro" End Sub Sub CancelOnTime() Application.OnTime MyTime, "MyMacro", , False End Sub Sub ResetTime() On Error Resume Next Application.OnTime EarliestTime:=MyTime, Procedure:="MyMacro", Schedule:=False MyTime = Now + TimeSerial(0, 1, 0) ' المدة الزمنية التى يعمل بعدها كودك Application.OnTime EarliestTime:=MyTime, Procedure:="MyMacro" On Error GoTo 0 End Sub Sub MyMacro() ' ضع كودك الذى تريد تشغيله اذا لم يكن الملف نشطا ' مثال Shell "C:\WINDOWS\system32\Bubbles.scr /S", vbMaximizedFocus ' انه كودك بالأمر التالى ResetTime End Sub 3 - احفظ الملف و أعد فتحه طالما أنت شغال على الملف لن يعمل الكود اذا توقفت عن العمل ستبدأ الفترة الومنية التى يعمل بعدها كودك تحياتى لكم وأتمنى أن ينال الملف اعجابك المرفق : تشغيل آلى لكود إذا ترك الاكسل بدون استخدام.rar5 points
-
السلام عليكم ورحمة الله وبركاته كيف حالكم إخواني الكرام في المنتدى الأغر ... هل ....؟ سؤال موجه لكم وليس لي هل .....؟ والإجابة على السؤال بهل إما بـ "نعم" أو بـ "لا" هل قمت يوماً ما بتحميل مصحف كامل لأحد القراء المحببين إليك؟ إذا كانت الإجابة بنعم انتقل للسؤال الثاني وإذا كانت الإجابة بـ "لا" .. مش عيب عليك تحمل أفلام ومسلسلات وألعاب وناسي كتاب الله السؤال الثاني : هل بعد عملية التحميل وجدت أن المجلد الذي يحتوي على السور مرقمة من 001 و 002 إلى 114 بدون أسماء السور؟ إذا كانت الإجابة بـ "نعم" فإليك الحل السحري مع الإكسل .. الحل هو دمج أسماء السور مع الاحتفاظ بالرقم أيضاً من أجل ترتيب السور ، لتصبح في النهاية بهذا الشكل 001 - الفاتحة ، 002 - البقرة وهكذا!! خطوات العمل : ************** قم بنسخ المصنف الذي سأقوم بإرفاقه في نفس مسار المجلد الذي يحتوي على السور القرآنية .. افتح المصنف .. اضغط زر الأمر .. وشكراً لكم على حسن تعاونكم معنا أترككم مع الملف :fff: Rename Quran Files.rar4 points
-
السلام عليكم بعد انضمامي للمنتدى و في فترة قصيرة جدا تعلمت أشياء جميلة جدا و خاصة البرمجة ب VBA في برنامج الاكسل والتي ساعدتني كثيرا في عملي فلكم مني شكر و دعاء لكم بالخير و قد قمت بنشر المنتدى في صفحتي الخاصة بالبرامج على موقع التواصل الاجتماعي4 points
-
السلام عليكم ورحمة الله وبركاته أخى أحمد الفلاحجى جزاك الله خيرا أخى و أستاذى الفاضل ياسر خليل جزاك الله خيرا وبعد اذن حضرتك أخى محمد الزريعى تفضل تم عمل المطلوب فى المرفق التالى بعد فك الضغط عن المرفق ستجد ملف + مجلد به ملفات 1 و 2 و 3 الخ كل واحد خاص بموظف ضع هذا المجلد فى البارتش d كما طلبت فى مشاركتك افتح الملف و شغل الكود و كرر التجربة مع تعديل بيانات الموظف ستجد ما تنشده بإذن الله أى استفسار سيكون معك أخوك مختار و أستاذنا ياسر خليل الفارس المغوار تحياتى loop through Excel files in a specified folder and perform a set task on them Mokhtar.rar3 points
-
السلام عليكم ورحمة الله وبركاته جزاكم الله خيراً أخي الحبيب ياسر على حرصك أكثرنا الجدال في موضوع كان لا بد أن يكون مغلقاً لأننا عرفنا أنه قد بتّ في أمره حرصاً على مصالح الكثيرين فإن نشر هذا البرنامج قد يسبب مضرة ... لنكتفِ بإرسال ملفاتنا التنفيذية إلى من باستطاعتهم فك شيفرتها ضمن حدود معينة ..أم ماذا تقولون؟؟. والسلام عليكم.3 points
-
السلام عليكم ورحمة الله وبركاته ****************** نويت بإذن الله تعالى - والله الموفق - أن أقوم بالبدء في هذا المشروع الكبير الذي أطلقت عليه اسم (مكتبة الصرح .. زاخرة بالشرح) بحثت عن ملف الأستاذ الكبير عبد الله باقشير (محفظة الأكواد) للعمل عليه .. ** رجاء من الأخ عبد الله .. إضافة للفورم في هذا الملف أن تكون عملية البحث غير مقتصرة على عناوين الأكواد فقط ، بل تشمل عمليه البحث الـ ListBox الذي يحوي الأكواد نفسها ، وكذلك صفحة التعليمات ، حتى يسهل فيما بعد على الباحث أن يصل لمراده بسهولة .. الأمر مختلف قليلاً عما قدم من قبل ، إذ أن الأكواد ستكون مصحوبة بالشرح (على قدر استطاعتي ) ولمن أراد أن يزيد على الشرح فليفعل ولا يتردد.. من هنا بإذن الله ستكون الإنطلاقة الكبرى نحو المشروع الكبير .. وسأحاول جاهداً أن أبدأ عملية بناء المكتبة بشكل منظم يسهل على الباحث فيما بعد الوصول للكود الذي يرغبه ، ويعرف كيف يقوم بتطبيق الكود بنفسه دون الحاجة لغيره .. يعني مبدأ الاعتماد على النفس في تطبيق الأكواد.. وإليكم الملف المرفق به 5 أكواد فقط مدعومة بالشرح منها 3 اكواد بسيطة ، وكود صعب قليلا ، ودالة معرفة UDF كنقطة بداية .. ملحوظة الأكواد مدعومة بالشرح في صفحة التعليمات . أرجو أن ينال رضاكم ... ولا تنسوا التصحيح والتنقيح إخواني أولاً بأول ، حتى يخرج العمل في النهاية بشكل لائق يليق بمنتدانا .. يليق بالصرح العملاق ولذا أسميت المشروع (مكتبة الصرح والصرح المقصود به منتدانا الغالي .. وإن شاء الله تكون المكتبة زاخرة وممتلئة بالشرح بعون الله وتوفيقه ثم بجهودكم ومساندتكم للمشروع) Codes Library.rar2 points
-
أخى الكريم // أهلا بك بمنتديات أوفيسنا التعليمية رجاء تغيير اسم الظهور الى اللغة العربية طبقا لتعليمات المنتدى ثانيا ارفقت لكم ما فهمته من طلباتك وهو الجزئيتين الأولى والثانية ستجد شكل مدون عليه اظهار فورم الإدخال قم بالضغط عليه لإظهار الفورم ومن خلالها تقوم بالإحال والبحث والترحيل الى نفس الشيت ( المطلب الأول والثانى ) طبعا لابد من تخفيض أمان الماكرو أما الباقى لم أفهم من اين تريد الترحيل والى من ويرجى توضيح ما انت مدونه بالشيتات وعدم دمج الخلايا لأن الترحيل لا يتم اثناء الدمج وتقبل منى وافر الاحترام والتقدير نموذج1.rar2 points
-
كل الشكر والتقدير لمروركم الكريم اما بخصوص البرنامج فأرجو قراءة الموضوع الى اخر الردود لتعرف انه تم وضع البرنامج مع بعض الاخوة وأساتذة المنتدى للاسباب المذكورة داخل الموضوع واذا كان لديك ملف تنفيذي خاص بك او مثال تعليمي او اي شئ من هذا القبيل واردت استخراج ملفك الاصلي يرجى عمل موضوع وارفاقه لفكه اما اذا كان مهم فتستطع ارسالة برسالة لى ويتم التعامل معه واذا تطابقت شروط الاستخراج سيتم ارساله لكم غير ذلك يتم تجاهله لكم مني كل التقدير ياسر العربي2 points
-
صراحة أنا أتفق تماما مع كلام أخى وأستاذى / ياسر خليل أبو البراء لأنه لا يوجد شىء اسمه مستحيل أو حتى صعب فعلى حد علمى هناك برامج أكثر قوة تصميما ...الخ ، وعليها حماية غير طبيعية بل هناك موظفون قائمون على حمايتها ويتم اختراقها ، فما بالك بملف تنفيذى أو خلافه فعلى سبيل المثال لا الحصر هناك بعض البنوك العاملة بدول الخليج ترسل ملفات تنفيذية لعملائها نظام الشركات للعمل عليها وتعبئة البيانات وارسالها مره أخرى للبنك بنظام الأون لاين ويتم اختراق تلك الملفات والله أعلم2 points
-
وهذه محاولتي: Dim x() As String x = Split(Me!name, " ") First_Letter = Left(Me!name, 1) Me.d = 0 For i = LBound(x) To UBound(x) If First_Letter = Left(x(i), 1) Then Me.d = Me.d + 1 End If Next i جعفر2 points
-
و عليكم السلام اخي العزيز سمير اضع لك احد الحلول و هو بالقيام بحذف الحرف الاول ثم ايجاد طول النص و مقارنته بطول النص الكامل .. لاحظ الاستعلام مصدر النموذج ملاحظة : تم تغيير بعض المسميات لحقل الاسم و النموذج ... بسبب استخدام اسم عربي للنموذج و اسم محجوز لحقل الاسم .. ايضاً تم حذف الحقل d من الجدول لانه يعتبر حقل محسوب لذا تم وضعه في الاستعلام باسم expr4 بالتوفيق othq.rar2 points
-
أخي الكريم ابن الملك المشكلة ليست في تعريف المتغيرات على ما أعتقد إنما تكمن المشكلة في بعض الدوال المستحدثة في الإصدارات الجديدة والتي لا توجد في الإصدارات القديمة وأنا شخصياً أفضل مواكبة التطور .. إحنا في 2016 ولسه الناس متعلقة بـ 2003 (بحجة إمكانيات الأجهزة ..) رغم إن النسخ الحديثة ممكن تشتغل على أجهزة إمكانياتها معقولة .. ممكن تحدد في المرفق الجزء اللي بتتكلم عليه .. وماذا تقصد تم تعريفها لأوفيس 2010 أو 2013 ؟؟ وما هي المشكلة التي تظهر عند استخدام 2007 مثلاً؟ تقبل تحياتي2 points
-
السلام عليكم و رحمة الله و بركاته اخوانى و أحبابى فى أوفيسنا اليوم باذن الله تعالى أعرض عليكم تعليمة برمجية صغيرة من سطر واحد تمكنك هذه التعليمة من الضغط على أى شكل تلقائى بمعلومية اسمه . مثال : اذا كان لديك شكلا تلقائيا اسمه Picture 1 كيف تضغط عليه برمجيا لا يدويا يمكن تنفيذ ذلك من خلال هذه التعليمة : Sub clickonashape() Application.Run ActiveSheet.Shapes("Picture 1").OnAction End Sub ممارسة الضغط على الشكل Picture 1 لن تشعر به الا اذا ربطت هذا الشكل بكود معين يؤكد لك أنه تم ضغطه لنربط الشكل بالكود التالى مثلا : Sub xxx() MsgBox "Hi Officna" End Sub جرب تشغيل الكود الأول ستجد أن الكود الثانى اشتغل و ظهرت الرسالة ( Hi Officna ) تطبيق على الكود السابق : اضافة شكل تلقائى لتشغيل كود مباشرة دون ربطه يدويا فى الكود التالى تم استثمار التعليمة السابقة و لكن بشكل مختلف : يتم اضافة شكل تلقائي فى مكان محدد بالشيت و له بعض الخصائص : من ضمن هذه الخصائص : أن يكون الشكل مربوطا بكود موجود مسبقا Sub addshpjoinedwithcode() Dim shp As Shape ' اضافة الشكل فى المكان المحدد Set shp = ActiveSheet.Shapes.AddShape(msoShapeSmileyFace, Left:=ThisWorkbook.Application.Range("E5").Left + 10, Top:=ThisWorkbook.Application.Range("E5").Top + 2, Width:=100, Height:=100) ' اضافة بعض الخصائص للشكل المضاف With shp .Name = "SmileyFace" .Fill.ForeColor.RGB = RGB(255, 192, 0) ' لون الشكل .Line.ForeColor.RGB = RGB(0, 176, 240) ' لون الخط .Adjustments.Item(1) = -2 ' الشكل يبدو عابسا .OnAction = "xxx" ' السطر الرئيسى : فى حالة ضغط الشكل يعمل الكود المحدد End With End Sub يعنى باختصار يلا يظهر الشكل تقدر تدوس عليه ليعمل الكود التالى : xxx Sub xxx() Application.ScreenUpdating = False With ActiveSheet.Shapes("SmileyFace") .Fill.ForeColor.RGB = RGB(146, 208, 80) ' لون الشكل الجديد .Line.ForeColor.RGB = RGB(192, 0, 0) ' لون الخط الجديد .Adjustments.Item(1) = 1 ' الشكل يبدو ضاحكا End With Application.ScreenUpdating = True MsgBox "Hi Officna" End Sub المرفقات : programmatically add shape , join it with specific code.rar programmatically click on a shape.rar أتمنى أن يكون الموضوع خفيفا و مفيدا لكم فى أكوادكم و برامجكم و السلام عليكم ورحمة الله وبركاته2 points
-
2 points
-
أخي الكريم أحمد لقد سبقني المعلم الكبير رجب بالحل .. ولكن بالفعل أن كنت مجهز حل من بدري لكن كان ينقصني فقط كلمة السر لإضافتها للكود .. عموماً الحل قريب جداً من الحل المقدم من أخونا الغالي رجب ..فقط اختلاف بسيط ، وإليك الكود إثراءً للموضوع لا أكثر Sub CreateSheets() Dim Cel As Range, strCel As String Application.ScreenUpdating = False ThisWorkbook.Unprotect 123 Sheet2.Unprotect 123 For Each Cel In Sheet1.Range("D4:R" & Sheet1.Cells(Rows.Count, 4).End(xlUp).Row) strCel = Trim(Cel.Value) If strCel <> "" Then If Not Evaluate("ISREF('" & strCel & "'!A1)") Then Sheet2.Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = strCel Cel.Hyperlinks.Add Cel, "", , "Screen_Tip", strCel Cel.Hyperlinks(1).SubAddress = "'" & strCel & "'" & "!A1" ActiveSheet.Protect 123 End If End If Next Cel ThisWorkbook.Protect 123 Sheet2.Protect 123 Application.ScreenUpdating = True MsgBox "Done ...", 64 End Sub تقبل تحياتي Create Sheets By Cells In Range & Add Hyperlinks YasserKhalil.rar2 points
-
1 point
-
السّلام عليكم و رحمة الله و بركاته بارك الله فيك أخي الغالي على الكلمات الطيّبة و الشّعور النّبيل تجاه منتدانا الحبيب "أوفيسنا" .. و في الواقع الاعتراف و العرفان بالجميل ..شيء جميل بحد ذاته فعلاً ..منتدى رائع بروعة أساتذته الأفاضل .. من بينهم أساتذتي الأعزّاء .. بالطّابق العلوي الذين سبقوني بمشاركاتهم بموضوعك هذا .. و كتشجيع لك وعرفان مني بالجميل .. أعترف مخلصًا أمام الله أنّ ياسر خليل أبو البراء مختار حسين محمود بن علية حاجي الصّقر ياسر العربي محمد حسن المحمد و كذلك كثير من الأساتذة الجديرين بالحب و التقدير و الاحترام هؤلاء هم ..سبب تمسّكي بعالم الاكسيل المثير و أعطوْا لأوقاتي أكثر من معنى بارك الله فيهم و لهم ..جزاهم الله خيرًا و زادها بميزان حسناتهم إحتراماتي1 point
-
خذ منها ما يكفى حاجة برنامجك .. والباقى اتركه لوحه الله مستقبلا تحياتى لك1 point
-
جزاك الله خير اخوي محمد وبارك فيك .. بالنسبة للأكواد والطرق فهي كثيرة .... الهدف من السؤال هو كان النقطة الأخيرة ... فقط .. وهو تأثير عملية النسخ على الأجهزة المتصلة وسير عمل البرنامج . وانت أكدتها مشكور وبأمثلة لأساتذتنا الكبار الأستاذ ابو خليل والأستاذ علي العتيبي . شكرا مرة اخرى وبالتوفيق للجميع .1 point
-
أخي الكريم البرنس حميد يرجى تغيير اسم الظهور للغة العربية قم بوضع المعادلة التالية في الخلية B2 ... =SUBSTITUTE(A2," ","") ثم بقم بسحبها لآخر النطاق المطلوب إذا لم تعمل معك المعادلة قم باستبدال الفاصلة العادية بفاصلة منقوطة تقبل تحياتي1 point
-
السلام عليكم أخي الحبيب الذي ضم اسمه الشرفين جزاكم الله خيرا ..سأبحث عن موضوعكم لمتابعته إن شاء الله تعالى..والسلام عليكم. Pc Programs1 point
-
1 point
-
والله العظيم ****والله العظيم ****والله العظيم ومن القلب جزاكم الله خيرا عدد حبات الرمال الله أسأل أن تكون من الامنين من عذاب الله يوم لاينفع مالا ولابنون الا من أتى الله بقلب سليم دعاءا صادقا من القلب ***** ولانكفيك حقك تحياتى لشخصكم الكريم وتحياتى لاخى الفاضل / ابو مرمر وجزاكم الله خيرا1 point
-
أخي العزيز جعفر المحترم: السلام عليكم ورحمة الله وبركاته... أشكركم على كلماتكم الطيبة ودعائكم وأرجو الله أن يهبكم الذرية الصالحة الناصحة..آمين وكما يقال الشيب دلى والعمر ولى.. أولئك نسغ الحياة الذين يشكلون استمرارية لآبائهم وأجدادهم. تقبل تحياتي العطرة .1 point
-
بالبركة أخوي محمد ان شاء الله وتتربى في عز والديها ، وجدها ان شاء الله وترى مو كل من اصبح جد يصبح شايب جعفر1 point
-
مرورك شرف كبير لي أخي الغالي مختار لا يعلم مقدار محبتك ومعزتك في قلبي سوى الله إني أحبك في الله ... تقبل وافر تقديري واحترامي1 point
-
الله الله عليك ربنا يعزك يا أستاااااااااااااااااااااااذى الغااااااااااااااااااااااااالى بس ازاى مشفتش الملف ده قبل كده ؟! أكيد كنت بآخد غطس تقبل منى وافر الاحترام والتقدير لشخصكم الكريم1 point
-
1 point
-
أخي الكريم محمد الخازمي ضع المعادلة التالية في الخلية D16 في ورقة ايصال =IF(ادخال!$J$13="دينار",ادخال!$I$13,"") وضع الكود التالي في حدث ورقة العمل الأولى "ادخال" ..كليك يمين على اسم ورقة العمل ثم View Code ثم الصق الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Address = "$K$13" Then If Target.Value = "بنك" Then Shapes("Check Box 8").OLEFormat.Object.Value = True Shapes("Check Box 10").OLEFormat.Object.Value = False Shapes("Check Box 12").OLEFormat.Object.Value = False ElseIf Target.Value = "بريد" Then Shapes("Check Box 8").OLEFormat.Object.Value = False Shapes("Check Box 10").OLEFormat.Object.Value = True Shapes("Check Box 12").OLEFormat.Object.Value = False ElseIf Target.Value = "بنفسة" Then Shapes("Check Box 8").OLEFormat.Object.Value = False Shapes("Check Box 10").OLEFormat.Object.Value = False Shapes("Check Box 12").OLEFormat.Object.Value = True End If End If End Sub تقبل تحياتي1 point
-
اخى الكريم المسلم العربى جزاكم الله خيرا على دعائك الطيب ولكن اسمح لى دام انك استفدت من المنتدى جاء الدور يا معلم انك تفيد يالا ورينا الهمه عايزين عضو خبير فى القريب العاجل تقبل تحياتى1 point
-
أخي الكريم مهند الزيدي إليك شرح لأسطر الكود لعله يفيد الجميع ، والشرح مهدى لأخونا الحبيب الغالي محمد حسن بمناسبة رجوعه بعد غياب أيام Sub CreateSheets() 'تعريف المتغيرات Dim Cel As Range, strCel As String 'إلغاء خاصية تحديث الشاشة لتسريع عمل الكود Application.ScreenUpdating = False 'إزالة الحماية عن المصنف بكلمة السر المرفقة ThisWorkbook.Unprotect 123 'إزالة الحماية عن ورقة العمل التي تمثل النموذج المراد نسخه Sheet2.Unprotect 123 'حلقة تكرارية لكل الخلايا في النطاق المطلوب إنشاء أوراق عمل لكل خلية من خلاياه For Each Cel In Sheet1.Range("D4:R" & Sheet1.Cells(Rows.Count, 4).End(xlUp).Row) 'إزالة المسافات الزائدة من الخلية strCel = Trim(Cel.Value) 'إذا لم تكن الخلية فارغة يتم تنفيذ الأسطر التالية أما إذا كانت فارغة يتم الانتقال للخلية التالية If strCel <> "" Then 'شرط لاختبار وجود ورقة العمل من عدم وجودها ، فإذا لم تكن ورقة العمل موجودة من قبل يتم تنفيذ التالي If Not Evaluate("ISREF('" & strCel & "'!A1)") Then 'نسخ ورقة العمل النموذج في نهاية المصنف Sheet2.Copy After:=Sheets(Sheets.Count) 'تسمية ورقة العمل التي تم نسخها باسم الخلية التي عليها العمل في الحلقة ActiveSheet.Name = strCel 'إنشاء ارتباط تشعبي للخلية لربطها بالورقة التي تم إنشائها Cel.Hyperlinks.Add Cel, "", , "Screen_Tip", strCel Cel.Hyperlinks(1).SubAddress = "'" & strCel & "'" & "!A1" 'حماية ورقة العمل الجديدة التي تم نسخها ActiveSheet.Protect 123 End If End If Next Cel 'إرجاع الحماية للمصنف ThisWorkbook.Protect 123 'إرجاع الحماية لورقة العمل النموذج Sheet2.Protect 123 'إعادة تفعيل خاصية تحديث الشاشة Application.ScreenUpdating = True 'رسالة تفيد بانتهاء عمل الكود كنوع من التنبيه لا أكثر MsgBox "Done ...", 64 End Sub تقبل تحياتي1 point
-
وهل بعد هذا الرد سيرد عليك سوى الأشباح ؟؟ ربما لم يفهم الأعضاء طلبك .هذا كل ما في الأمر ، والدليل على أنه يوجد أشباح أن هناك الكثير من الموضوعات التي تم الرد عليها من قبل أشباح .. لا نعلم من أين يأتون ولكنهم يظهرون ويختفون لأنهم ببسااااااااطة أشباح .. أحلى صباح من منتدى الأشباح لأخونا الكريم أبو عبد الله وأخونا أحمد الفلاح1 point
-
أخي الكريم محمود أبو سيف يرجى تغيير اسم الظهور للغة العربية (وهذا ليس أول نداء لك لتغيير اسم الظهور) إليك الملف التالي عله يفي ببعض من طلبك .. البضاعة.rar1 point
-
1 point
-
أستاذى الغالى ياسر خليل بارك الله فيك و جزاك كل خير ... شوفت الغطس بيعمل ايه يا أحلى مستر أحاول أن أقدم لكم شيئا و لو ضئيلا مما تقدمه لاخوانك أستاذنا الغالى أخى الغالى ياسر العربى أولا مبروووووووووووك على انضمامك لفريق الموقع ومشكور على مرورك الجميل1 point
-
1 point
-
1 point
-
1 point
-
يتم تجزيء الجدول فى حالة كونه كثير الحقول وهذا ما لا ينطبق على حالتك ثم إن العلاقات الكثيرة قد تكون سببا فى البطء1 point
-
أخي الكريم طارق صراحة الموضوع معقد بعض الشيء لكن بفضل الله وحده تمكنت من الوصول لسبب المشكلة وهو الإجراء الفرعي في حدث الفورم اخذف الإجراء الموجود واستبدل التالي مكانه Sub ListArr(Cmd As String) Dim sTe As String: sTe = Me(Cmd).Text Dim II As Long, E As Long E = 0 For II = LBound(Arr1) To UBound(Arr1) If CStr(Arr1(II)) <> sTe And Not IsEmpty(Arr1(II)) Then E = E + 1: ReDim Preserve Arr2(E - 1) Arr2(E - 1) = Arr1(II) End If Next II ReDim Arr1(E): Arr1 = Arr2 End Sub تقبل تحياتي1 point
-
أستاذ نايف جرب التحميل مرة أخرى عذرا فقد حدث خطأ أثناء اضافة الموضوع1 point
-
1 point
-
أخي الكريم جرب التعديل التالي Sub CreateNewSheet() Dim Ws As Worksheet, Sh As Worksheet, Str As String, Y As Integer, X Set Sh = Sheet1 For Each Ws In ThisWorkbook.Worksheets Str = Ws.Range("D3").Formula X = Val(Mid(Str, 2, InStr(Str, "&") - 1)) If Y > X Then Y = Y Else Y = X Next Ws Sh.Copy After:=Sheets(Sheets.Count) With ActiveSheet .Name = "نقد " & Y + 1 .Range("D3").Formula = Replace(.Range("D3").Formula, Val(Mid(.Range("D3").Formula, 2, InStr(.Range("D3").Formula, "&") - 1)), Y + 1) End With Sh.Activate: Sh.Range("A1").Select End Sub فاتورة 2016.rar1 point
-
أخي الكريم علي المصري إثراءً للموضوع وإضافة للحل الرائع المقدم من أخونا المتميز سليم إليك حل بالأكواد مع الشرح بالتفصيل ..لتستطيع التعديل بما يتناسب مع ملفك الأصلي Sub FilterMarks() 'تعريف المتغيرات Dim Counter As Integer, LR As Integer, I As Integer 'إلغاء تحديث الشاشة لتسريع الكود Application.ScreenUpdating = False 'بدء التعامل مع ورقة العمل النشطة With ActiveSheet 'مسح النطاق الذي ستوضع فيه النتائج .Range("J10:M1000").ClearContents 'حلقة تكرارية من 1 إلى 3 حسب عدد الأعمدة التي سيتم التعامل معها 'فالأعمدة التي سيتم التعامل معها وفلترتها هي العمود ف1 و ف2 و ف3 For Counter = 1 To 3 'إلغاء الفلترة في ورقة العمل قبل البدء في عمليات الفلترة .AutoFilterMode = False 'فلترة النطاق حسب الحقل رقم 2 في الحلقة الأولى ورقم 3 في الحلقة الثانية ورقم 4 في الحلقة الثالثة 'لنستطيع التعامل مع الثلاثة حقول ف1 و ف2 وف3 [Counter] وهنا استخدمنا المتغير المسمى 'وشرط الفلترة أكبر من الدرجة صفر وأقل من أو يساوي الدرجة 50 .Range("B2:E2").AutoFilter Field:=Counter + 1, Criteria1:=">0", Operator:=xlAnd, Criteria2:="<=50" 'نسخ النطاق الذي يحتوي الأسماء ويكون النسخ للخلايا الظاهرة فقط والتي تطابق الشروط .Range("B3:B" & Cells(Rows.Count, "B").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy 'لصق الأسماء في العمود المناسب حيث يكون اللصق في أول حلقة في العمود رقم 11 'وفي الحلقة الثانية في العمود رقم 12 وفي الحلقة الثالثة في العمود رقم 13 'اللصق يكون للقيم فقط بحيث نحافظ على التنسيقات الموجودة في نطاق النتائج .Cells(10, Counter + 10).PasteSpecial xlPasteValues 'تحديد أول خلية في ورقة العمل .Range("A1").Select 'الانتقال للحلقة التالية Next Counter 'إلغاء الفلترة في ورقة العمل .AutoFilterMode = False 'تحديد آخر صف في نطاق النتائج من خلال معرفة عدد صفوف النطاق الحالي مضافاً إليها 7 'يمثل الرقم 7 عدد الصفوف السابقة للنطاق الحالي أي نطاق النتائج LR = .Range("K9").CurrentRegion.Rows.Count + 7 'حلقة تكرارية من الصف رقم 10 إلى آخر صف في النطاق الحالي For I = 10 To LR 'الخلية في العمود العاشر تساوي قيمة العداد مطروح منه 9 ليعطي تسلسل للنتائج .Cells(I, "J") = I - 9 'الانتقال للحلقة التالية Next I 'انتهاء التعامل مع ورقة العمل الحالية End With 'إلغاء خاصية القص واللصق بعد عمليات النسخ Application.CutCopyMode = False 'إعادة تفعيل تحديث الشاشة Application.ScreenUpdating = True End Sub تقبل تحياتي Filter & AutoFilter Tutorial YasserKhalil.rar1 point
-
إنت قلت ايه ؟؟ صعب ..يعني مش مستحيل .. لأن فيه حاجة اسمها الهندسة العكسية ... حتى لو كان التعرف على بيانات الجهاز فدا عشان يقوم بعمليات حسابية ومنطقية على أساس البيانات دي ودا ممكن بردو ينضرب .. من الآخر لكل فعل رد فعل مساوي له في المقدار ومضاد له في الاتجاه وطالما وجدت الحماية وجدت كسر الحماية والعكس صحيح تقبل تحياتي1 point
-
اتفضل يا اخي هذا المتصفح الصغير بإذن الله هيشتغل مع حضرتك hosamh3.rar وتكون الحروف سليمة1 point
-
يا ياسر فكرتنى بحكاية لطيفة جماعة قالوا لواحد : تقدر تشيل الخروف ده ؟ قال لهم : آآآآآآآه هاتو الخروف ده هو فين ؟ هو فين و أنا أشيل أمه ؟ قام الجماعة جابو الخروف للراجل وقالوا الخروف اهه تفضل اهه الراجل ميل كتفه عشان يشيل الخروف مقدرش فقالوا له : هــــــــــــــا ! قال : معلش أنا مولف على شيل الجمال ! و الله أنت يا ياسر ابن حلال ضحكتنى بجد تحياتى لك و لعبدالعزيز1 point
-
أستاذي القدير / ياسر خليل عمل رائع جدا ماشاء الله أنا أستعمل برنامج RENAME QURAN FILES به ناتج تسمية الملفات - الرقم 001 - التسمية العربية الفاتحة - التسمية الإنجليزية Al-Fatiha - القارئ -تسمية الملف بالخيارات الأربع 001 - الفاتحة - Al-Fatiha - السديس و الشريم ياريت إضافة لهذا الكود ليصبح الملف أروع وإليكم الملف لمن يحتاجه RENAME QURAN FILES PORTABLE.rar1 point
-
السلام عليكم استاذنا القدير حاولت اضيف على كودك طلبي الاخير وزبط معي الحمد لله هذا الكود بعد الاضافة للفائده العامة Sub T_shift() file1 = ActiveWorkbook.Name pth = ActiveWorkbook.Path f2Name = "قاعدة بيانات.xls" file2 = pth & "\" & f2Name On Error Resume Next 'إحتياطي لإحتمال ان يكون ملف قاعدة بيانات مفتوح بالفعل Set F_check = Excel.Workbooks(f2Name) If Err = 0 Then GoTo 10 Workbooks.Open Filename:=file2 10 'وضع خط أسفل آخر قيم في ملف قاعدة بيانات rr = Workbooks(f2Name).Sheets(1).[A1000].End(xlUp).Row Workbooks(f2Name).Sheets(1).Range("A" & rr & ":G" & rr).Borders(xlEdgeBottom).LineStyle = xlContinuous Workbooks(f2Name).Sheets(1).[a1].Select Workbooks(file1).Activate ' نسخ قيم فقط للبيانات التي توافق الشرط For a = 2 To [G1000].End(xlUp).Row If Cells(a, 7) = "يعتمد" Then Range(Cells(a, 1), Cells(a, 7)).Copy Workbooks(f2Name).Sheets(1).[A1000].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues ic = ic + 1 End If Next a Application.CutCopyMode = False Application.ScreenUpdating = False Sheets("ورقة1").Select LastRow = Cells(Rows.Count, 1).End(xlUp).Row For y = LastRow To 2 Step -1 If Cells(y, "g").Value = "يعتمد" Then Rows(y).EntireRow.Delete Next y Application.ScreenUpdating = True 'وضع خط مرة أخري أسفل آخر قيم في ملف قاعدة بيانات rr = Workbooks(f2Name).Sheets(1).[A1000].End(xlUp).Row Workbooks(f2Name).Sheets(1).Range("A" & rr & ":G" & rr).Borders(xlEdgeBottom).LineStyle = xlContinuous 'رسالة بالبيانات المرحلة MsgBox (" تم ترحيل عدد" & ic & " بيان معتمد بنجاح") [a1].Select Workbooks(f2Name).Activate Range("A" & rr + 1).Select 'رسالة أخري من ملف قاعدة بيانات للتأكيد MsgBox "!تمام", vbInformation + vbMsgBoxRight, "تم الترحيل" Workbooks(file1).Activate With Workbooks(f2Name) .Save .Close End With End Sub1 point
-
السلام عليكم شكرا لانك قبلت ان اشارك ان لم تشكرنا نشكرك نحن _________Microsoft_Excel_New___3_.rar1 point