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

السلام عليكم ورحمة الله وبركاته كنت منذ فترة قدمت لحضراتكم موضوعا بعنوان : إغلاق آلى لملف اكسل إذا ترك بدون استخدام على الرابط التالى : 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 - احفظ الملف و أعد فتحه طالما أنت شغال على الملف لن يعمل الكود اذا توقفت عن العمل ستبدأ الفترة الومنية التى يعمل بعدها كودك تحياتى لكم وأتمنى أن ينال الملف اعجابك المرفق : تشغيل آلى لكود إذا ترك الاكسل بدون استخدام.rar

السلام عليكم ورحمة الله وبركاته كيف حالكم إخواني الكرام في المنتدى الأغر ... هل ....؟ سؤال موجه لكم وليس لي هل .....؟ والإجابة على السؤال بهل إما بـ "نعم" أو بـ "لا" هل قمت يوماً ما بتحميل مصحف كامل لأحد القراء المحببين إليك؟ إذا كانت الإجابة بنعم انتقل للسؤال الثاني وإذا كانت الإجابة بـ "لا" .. مش عيب عليك تحمل أفلام ومسلسلات وألعاب وناسي كتاب الله السؤال الثاني : هل بعد عملية التحميل وجدت أن المجلد الذي يحتوي على السور مرقمة من 001 و 002 إلى 114 بدون أسماء السور؟ إذا كانت الإجابة بـ "نعم" فإليك الحل السحري مع الإكسل .. الحل هو دمج أسماء السور مع الاحتفاظ بالرقم أيضاً من أجل ترتيب السور ، لتصبح في النهاية بهذا الشكل 001 - الفاتحة ، 002 - البقرة وهكذا!! خطوات العمل : ************** قم بنسخ المصنف الذي سأقوم بإرفاقه في نفس مسار المجلد الذي يحتوي على السور القرآنية .. افتح المصنف .. اضغط زر الأمر .. وشكراً لكم على حسن تعاونكم معنا أترككم مع الملف :fff: Rename Quran Files.rar

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

السلام عليكم ورحمة الله وبركاته أخى أحمد الفلاحجى جزاك الله خيرا أخى و أستاذى الفاضل ياسر خليل جزاك الله خيرا وبعد اذن حضرتك أخى محمد الزريعى تفضل تم عمل المطلوب فى المرفق التالى بعد فك الضغط عن المرفق ستجد ملف + مجلد به ملفات 1 و 2 و 3 الخ كل واحد خاص بموظف ضع هذا المجلد فى البارتش d كما طلبت فى مشاركتك افتح الملف و شغل الكود و كرر التجربة مع تعديل بيانات الموظف ستجد ما تنشده بإذن الله أى استفسار سيكون معك أخوك مختار و أستاذنا ياسر خليل الفارس المغوار تحياتى loop through Excel files in a specified folder and perform a set task on them Mokhtar.rar

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

السلام عليكم ورحمة الله وبركاته ****************** نويت بإذن الله تعالى - والله الموفق - أن أقوم بالبدء في هذا المشروع الكبير الذي أطلقت عليه اسم (مكتبة الصرح .. زاخرة بالشرح) بحثت عن ملف الأستاذ الكبير عبد الله باقشير (محفظة الأكواد) للعمل عليه .. ** رجاء من الأخ عبد الله .. إضافة للفورم في هذا الملف أن تكون عملية البحث غير مقتصرة على عناوين الأكواد فقط ، بل تشمل عمليه البحث الـ ListBox الذي يحوي الأكواد نفسها ، وكذلك صفحة التعليمات ، حتى يسهل فيما بعد على الباحث أن يصل لمراده بسهولة .. الأمر مختلف قليلاً عما قدم من قبل ، إذ أن الأكواد ستكون مصحوبة بالشرح (على قدر استطاعتي ) ولمن أراد أن يزيد على الشرح فليفعل ولا يتردد.. من هنا بإذن الله ستكون الإنطلاقة الكبرى نحو المشروع الكبير .. وسأحاول جاهداً أن أبدأ عملية بناء المكتبة بشكل منظم يسهل على الباحث فيما بعد الوصول للكود الذي يرغبه ، ويعرف كيف يقوم بتطبيق الكود بنفسه دون الحاجة لغيره .. يعني مبدأ الاعتماد على النفس في تطبيق الأكواد.. وإليكم الملف المرفق به 5 أكواد فقط مدعومة بالشرح منها 3 اكواد بسيطة ، وكود صعب قليلا ، ودالة معرفة UDF كنقطة بداية .. ملحوظة الأكواد مدعومة بالشرح في صفحة التعليمات . أرجو أن ينال رضاكم ... ولا تنسوا التصحيح والتنقيح إخواني أولاً بأول ، حتى يخرج العمل في النهاية بشكل لائق يليق بمنتدانا .. يليق بالصرح العملاق ولذا أسميت المشروع (مكتبة الصرح والصرح المقصود به منتدانا الغالي .. وإن شاء الله تكون المكتبة زاخرة وممتلئة بالشرح بعون الله وتوفيقه ثم بجهودكم ومساندتكم للمشروع) Codes Library.rar

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

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

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

وهذه محاولتي: 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 جعفر

و عليكم السلام اخي العزيز سمير اضع لك احد الحلول و هو بالقيام بحذف الحرف الاول ثم ايجاد طول النص و مقارنته بطول النص الكامل .. لاحظ الاستعلام مصدر النموذج ملاحظة : تم تغيير بعض المسميات لحقل الاسم و النموذج ... بسبب استخدام اسم عربي للنموذج و اسم محجوز لحقل الاسم .. ايضاً تم حذف الحقل d من الجدول لانه يعتبر حقل محسوب لذا تم وضعه في الاستعلام باسم expr4 بالتوفيق othq.rar

أخي الكريم ابن الملك المشكلة ليست في تعريف المتغيرات على ما أعتقد إنما تكمن المشكلة في بعض الدوال المستحدثة في الإصدارات الجديدة والتي لا توجد في الإصدارات القديمة وأنا شخصياً أفضل مواكبة التطور .. إحنا في 2016 ولسه الناس متعلقة بـ 2003 (بحجة إمكانيات الأجهزة ..) رغم إن النسخ الحديثة ممكن تشتغل على أجهزة إمكانياتها معقولة .. ممكن تحدد في المرفق الجزء اللي بتتكلم عليه .. وماذا تقصد تم تعريفها لأوفيس 2010 أو 2013 ؟؟ وما هي المشكلة التي تظهر عند استخدام 2007 مثلاً؟ تقبل تحياتي

السلام عليكم و رحمة الله و بركاته اخوانى و أحبابى فى أوفيسنا اليوم باذن الله تعالى أعرض عليكم تعليمة برمجية صغيرة من سطر واحد تمكنك هذه التعليمة من الضغط على أى شكل تلقائى بمعلومية اسمه . مثال : اذا كان لديك شكلا تلقائيا اسمه 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 أتمنى أن يكون الموضوع خفيفا و مفيدا لكم فى أكوادكم و برامجكم و السلام عليكم ورحمة الله وبركاته

تمت اضافة السطر المحدد فى الصورة السابقة

أخي الكريم أحمد لقد سبقني المعلم الكبير رجب بالحل .. ولكن بالفعل أن كنت مجهز حل من بدري لكن كان ينقصني فقط كلمة السر لإضافتها للكود .. عموماً الحل قريب جداً من الحل المقدم من أخونا الغالي رجب ..فقط اختلاف بسيط ، وإليك الكود إثراءً للموضوع لا أكثر 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.rar

الف شكر لك اخي محد سلامة وبالتوفيق انشاء الله

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

هههههه جزاك الله خير حبيبي

خذ منها ما يكفى حاجة برنامجك .. والباقى اتركه لوحه الله مستقبلا تحياتى لك

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

السلام عليكم اخى سعيد صواب تفضل هذا البرنامج .. بصيغة 2010 ---BackUpControl.rar وبصيغة 2003 ---x.rar اليك طريقة العمل .. اذا كان مثلا لديك 5 مستخدمين يمكنك ان تجعل منهم مستخدم هو ال admin وهو يقوم بالعملية او تجعل اي نسخه لدى اى مستخدم منهم (مثلا اكثر مستخدم يقوم باستخدام برنامجك) وتضع بها محتويات المرفق بعاليه ثم تقوم بمنادة الكود عند حدث الخروج من النموذج الرئيسي مثلا او اي شى ترغب به سواء مثلا زر امر بهذا الامر vback والكود الموجود بالوحدة النمطية هو Option Compare Database Public Function vback() Dim DBOld As String Dim DBNew As String Dim BackUpname As String Dim BackUpType As String DBOld = DLookup("pate1", "copy1") ' ÞÇÚÏÉ ÈíÇäÇÊ ÇáãÑÊÈØÉ DBNew = DLookup("pate_copy", "copy1") ' ãßÇä ÍÝÙ ÇáäÓÎÉ BackUpname = DLookup("c_ymd", "copy1") BackUpType = DLookup("cv", "copy1") Dim vvs If BackUpname = 1 Then vvs = Format(Now(), "yyyy-mm-dd-hh") ElseIf BackUpname = 2 Then vvs = Format(Now(), "yyyy-mm-dd") ElseIf BackUpname = 3 Then vvs = Format(Now(), "yyyy-mm") ElseIf BackUpname = 4 Then vvs = Format(Now(), "yyyy") End If Shell "cmd.exe /C copy " & """" & DBOld & """" & " " & """" & _ DBNew & "\" & vvs & BackUpType & """", 0 End Function تحياتى لك .. وجاهز باى رد وتحية للسيد ابو خليل هو من امدانى بهذه الطريقة فى هذا الرابط تعتبر فعلا عملية نسخ ولصق .. ولا تؤثر على عمل القاعدة الخلفية بتاتاً وهذه محاولة اخري للفائدة .. وهى لاستاذ ابا فيصل (strtnet) بارك الله فيه BackUp2003-2007.rar

أخي الكريم البرنس حميد يرجى تغيير اسم الظهور للغة العربية قم بوضع المعادلة التالية في الخلية B2 ... =SUBSTITUTE(A2," ","") ثم بقم بسحبها لآخر النطاق المطلوب إذا لم تعمل معك المعادلة قم باستبدال الفاصلة العادية بفاصلة منقوطة تقبل تحياتي

أخي الكريم أبو هايدي ضع الأسطر التالية لتؤدي الغرض إن شاء الله Private Sub TextBox2_Change() If TextBox2 <> "" And TextBox3 <> "" Then TextBox4.Value = Val(TextBox2) / Val(TextBox3) Else TextBox4.Value = "" End Sub Private Sub TextBox3_Change() If TextBox2 <> "" And TextBox3 <> "" Then TextBox4.Value = Val(TextBox2) / Val(TextBox3) Else TextBox4.Value = "" End Sub

السلام عليكم أخي الحبيب الذي ضم اسمه الشرفين جزاكم الله خيرا ..سأبحث عن موضوعكم لمتابعته إن شاء الله تعالى..والسلام عليكم. Pc Programs

جزاك الله خيرا اخي " ياسر خليل "

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

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

جزاكم الله خيراً

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

أخي الكريم أبو مرمر أفضل كلمة "جزاكم الله خيراً " أكثر من كلمات الشكر والثناء .. تقبل وافر تقديري واحترامي

مرورك شرف كبير لي أخي الغالي مختار لا يعلم مقدار محبتك ومعزتك في قلبي سوى الله إني أحبك في الله ... تقبل وافر تقديري واحترامي

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

بارك الله فيك على حسن استجابتك بتغيير اسم الظهور تقبل تحياتي

أخي الكريم محمد الخازمي ضع المعادلة التالية في الخلية 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 تقبل تحياتي

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

بارك الله فيك اخي الفاضل jandbi طريقة ممتازة

أخى الفاضل جرب المرفق مثال توضيحي.rar

أخي الكريم مهند الزيدي إليك شرح لأسطر الكود لعله يفيد الجميع ، والشرح مهدى لأخونا الحبيب الغالي محمد حسن بمناسبة رجوعه بعد غياب أيام 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 تقبل تحياتي

أخي الكريم محمود أبو سيف يرجى تغيير اسم الظهور للغة العربية (وهذا ليس أول نداء لك لتغيير اسم الظهور) إليك الملف التالي عله يفي ببعض من طلبك .. البضاعة.rar

السلام عليكم و رحمة الله شخصيا حاولت مرارا فى هذا الموضوع لم أصل الى شىء كلمة السر و اسم المستخدم كلمات حساسة لابد من ادخالها يدويا فى السواد الأعظم من المواقع الكود التالى يعطى الصفحة الرئيسية للمنتدى تماما مثل مرفق أخى الغالى عبدالعزيز البسكرى Sub Openofficena() Dim Website As String Website = "http://www.officena.net/ib/?_fromLogin=1&_fromLogout=1" ActiveWorkbook.FollowHyperlink Address:=Website, NewWindow:=True End Sub تحياتى

أخي الكريم جرب التعديل التالي 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.rar

أخي الكريم علي المصري إثراءً للموضوع وإضافة للحل الرائع المقدم من أخونا المتميز سليم إليك حل بالأكواد مع الشرح بالتفصيل ..لتستطيع التعديل بما يتناسب مع ملفك الأصلي 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.rar

حياك الله اخي الكريم مشاركة مع الأستاذ عبدالرحمن ... بالنسبة لعلامة العلاقة ... ادخل على الجدول في عرض التصميم وشاهد ورقة الخصائص على اليسار قم بإزالة ورقة البيانات الفرعية .. الدورات . بالنسبة لنموذج البحث .. ادخل على مصدر بيانات النموذج واضف الشرط التالي ... كما هو موضح في مرفق الاستاذ عبدالرحمن .. Like "*" & ClrText([forms]![main1]![Text1]) & "*" بالتوفيق

أخي الفاضل إبراهيم جرب الكود التالي عله يفي بالغرض Sub PopulateData() Dim Ws As Worksheet, Sh As Worksheet Dim I As Long, Col As Long Set Ws = Sheet1: Set Sh = Sheet2 Col = 1 Application.ScreenUpdating = False Sh.Range("A1").CurrentRegion.Offset(1).ClearContents With Ws For I = 2 To .Cells(Rows.Count, 1).End(xlUp).Row Step 45 .Cells(I, 1).Resize(45, 2).Copy Sh.Cells(Sh.Cells(Rows.Count, Col).End(xlUp).Row + 1, Col).PasteSpecial xlPasteValues If Col = 11 Then Col = 1 Else Col = Col + 2 Next I End With Application.CutCopyMode = False Application.ScreenUpdating = True End Sub وإليك الملف المرفق ..غيرت فقط أسماء أوراق العمل ولن يؤثر على عمل الكود Populate Data From One Column To Multiple Columns YasserKhalil.rar

اتفضل يا اخي هذا المتصفح الصغير بإذن الله هيشتغل مع حضرتك hosamh3.rar وتكون الحروف سليمة

أستاذي القدير / ياسر خليل عمل رائع جدا ماشاء الله أنا أستعمل برنامج RENAME QURAN FILES به ناتج تسمية الملفات - الرقم 001 - التسمية العربية الفاتحة - التسمية الإنجليزية Al-Fatiha - القارئ -تسمية الملف بالخيارات الأربع 001 - الفاتحة - Al-Fatiha - السديس و الشريم ياريت إضافة لهذا الكود ليصبح الملف أروع وإليكم الملف لمن يحتاجه RENAME QURAN FILES PORTABLE.rar

تعلم أكسس 2007 | الفصل السابع عشر: الاستيراد والتصدير

وعليكم السلام الاستاذ الحبيب والخلوق جدا طارق محمود جزئية حذف سطور (يعتمد) تم معي بهذا الجزء لم استخدم الفلترة 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 جزاك الله خير ونور دروبك كما تنورنا بالعلم

السلام عليكم استاذنا القدير حاولت اضيف على كودك طلبي الاخير وزبط معي الحمد لله هذا الكود بعد الاضافة للفائده العامة 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 Sub

السلام عليكم تفضل اخي المرفق بشرط ان يكون الملفين في نفس المجلد وهذا هو الكود بالتفصيل 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 'وضع خط مرة أخري أسفل آخر قيم في ملف قاعدة بيانات 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 End Sub ترحيل_TAREQ.rar