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

السلام عليكم ورحمة الله وبركاته كنت منذ فترة قدمت لحضراتكم موضوعا بعنوان : إغلاق آلى لملف اكسل إذا ترك بدون استخدام على الرابط التالى : 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," ","") ثم بقم بسحبها لآخر النطاق المطلوب إذا لم تعمل معك المعادلة قم باستبدال الفاصلة العادية بفاصلة منقوطة تقبل تحياتي

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

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

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

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

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

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

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

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

اخي العزيز angel eyes نرجوا تغيير اسم الظهور للغة العربية ويرجى قراءة توجيهات المنتدى جيدا واذا اردت مساعدة من الاخوة فيجب التسهيل عليهم بالشرح وارفاق مثال لما ترغب بعمله وشكرا

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

لا شكر على واجب أخى الفاضل محمد

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

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

جزاك الله خير عمل رائع سلمت يمينك يا أبو البراء بالتوفيق اخى ياسر وزاذك الله من فضله وعلمه

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

بعد اذن أخى الفاضل سليم جرب أخى هذه المعادلة =IF(H2=943;"نعم";"لا")

أخى الحبيب / ياسر ( فاكهة المنتدى ) ربنا يبارك فيك ويديم المودة

تفضل الطريقة السليمة في المرفق BackUpAuto.zip البرنامج يقوم باخذ نسخة احتياطية في نفس مجلد البرنامج اذا اردت ان تحدد انت مسار النسخة الاحتياطية .. قم بتغيير CurrentProject.Path الى مثلاً .. "D:\Backup"

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

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

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

تفضل أخى الفاضل جرب هذه الفكرة اكرم.rar

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

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

يا ياسر فكرتنى بحكاية لطيفة جماعة قالوا لواحد : تقدر تشيل الخروف ده ؟ قال لهم : آآآآآآآه هاتو الخروف ده هو فين ؟ هو فين و أنا أشيل أمه ؟ قام الجماعة جابو الخروف للراجل وقالوا الخروف اهه تفضل اهه الراجل ميل كتفه عشان يشيل الخروف مقدرش فقالوا له : هــــــــــــــا ! قال : معلش أنا مولف على شيل الجمال ! و الله أنت يا ياسر ابن حلال ضحكتنى بجد تحياتى لك و لعبدالعزيز

السلام عليكم Private Sub Worksheet_SelectionChange(ByVal Target As Range) Range("yyy").Interior.Color = [B2].Interior.Color ورقة2.Range("RRR").Interior.Color = [B2].Interior.Color End Sub تحياتي

السلام عليكم ورحمة الله أخي الكريم يمكن استعمال الكود التالي في حدث الورقة : Private Sub Worksheet_SelectionChange(ByVal Target As Range) [Plage].Interior.Color = [B2].Interior.Color End Sub ألق نظرة على المرفق... أخوك بن علية المرفق : اللون.rar

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

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

السلام عليكم شكرا لانك قبلت ان اشارك ان لم تشكرنا نشكرك نحن _________Microsoft_Excel_New___3_.rar