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

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

أخي الكريم أبو هايدي ضع الأسطر التالية لتؤدي الغرض إن شاء الله 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

إبداع ورا إبداع ...تميز بلا حدود فكر جديد وعصر جديد لك أخي الحبيب مختار تعجبني موضوعاتك المميزة والفريدة من نوعها تقبل وافر تقديري واحترامي

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

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

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

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

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

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

ولا يهمك جرب هالكود: Private Sub Form_Current() On Error GoTo err_Form_Current Dim rst As DAO.Recordset mySQL = "SELECT Val([رقم العميل]) AS R FROM البيانات ORDER BY Val([رقم العميل]) DESC" Set rst = CurrentDb.OpenRecordset(mySQL) rst.MoveLast: rst.MoveFirst Me.نص155 = rst!r rst.Close: Set rst = Nothing Exit Sub err_Form_Current: If Err.Number = 3021 Then 'ignor, No Records Me.نص155 = 0 Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub جعفر

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

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

السلام عليكم أخي الكريم تفضل جرب هذا الكود وإن شاء الله يكون هو المطلوب DoCmd.SelectObject acForm, "", True DoCmd.RunCommand acCmdWindowHide

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

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

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

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

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

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

تفضل الطريقة السليمة في المرفق 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 تحياتى

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

اخى الكريم اكرم حضرتك عملت موضوعين لنفس الطلب يرجى مراعاة ذالك بالمرات القادمه وكمان من فضلك ترفق ملف يوضح المطلوب بعد اذن الاستاذ الفاضل رجب جاويش من باب التنوع واثراء للموضوع جرب الكود التالى الكود يتم وضعه بحدث التغيير بالتكست بوكس Private Sub TextBox15_Change() If Len(TextBox15) = 14 Then For i = 1 To 14 Me.Controls("textbox" & i).Value = Mid(TextBox15, i, 1) Next End If End Sub تقبل تحياتى ====================================

عذرا أخى فقد نسيت هذه النقطة تفضل تجزئه3.rar

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

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

السلام عليكم اخي قنديل كما اوضحت سابقا الترقية للجيل الرابع ضرورة و ليس خيار ، و لا اعتقد ان هذه النسخة ينقصها الكثير عن سابقتها بل فيها مميزات اضافية. و هناك اشياء يمكن اضافتها مع الوقت و ليس الاهم هو الشكليات لانها مقدور عليها و يمكن تعديلها مع الوقت و سياتي عليها تعديلات متعددة باذن الله اما النسخة السابقة ، فلا مستقبل لها حيث اوقفت الشركة المنتجة تطويرها فعليا ، لذا مع تطور لانظمة التشغيل لدى المستخدمين او السيرفر سيظهر فيها مشاكل جوهرية لن نستطيع التعامل معها دون دعم فني من الشركة ناهيك عن متطلبات الامن و خلافه و التي ستتأثر بتوقف التطوير. ان الترقية الي الجيل الرابع خيار استراتيجي من ناحية التطوير المستقبلي و الحماية و الامن و هذا امر لا شك فيه و مثلا درجة توافق النسخة الحالية مع اجهزة الهاتف لا يقارن بسابقتها و ان كان مازال يحتاج الي تحسين ، ايضا سرعة الاداء مختلفة الان و هناك تحسينات كثير مثل سحب المرفقات الى صندوق التحميل مثلا. اما العودة للنسخة السابقة فمعناه بالاضافة الي خسران المميزات المستقبلبة و مواكبة التطوير فانه معناه العودة لتاريخ 18 يوليو و خسران مشاركات ما يزيد على شهر ، حيث ان تصميم قواعد البيانات مختلف و به تعديلات كبيرة و لا يمكن التحويل ، فالشركة تقدم سكريبتات للترقية فقط و ليس للعودة للنسخة السابقة , كل ما يمكن هو استعادة النسخة بتاريخ 17 يوليو بحالتها و بياناتها. لم اشأ التطرق الي هذا سابقا ، و لكن الترقية يم تكن نزهة ، و لم يمكننا خلالها الاهتمام كثيرا بالشكليات ، و كل فترة يصلنا تعليق عن النسخة ما بين انتقاد و ما بين التحدث مزاحاً عن ثورة فى المنتدى بالرغم مما تم توضيحه ، بينما التغلب على مشاكل الترقية نفسها تطلب مجهود و ضغط غير غير عادي ربما لم نمر بمثله منذ افتتاح المنتدى فى عام 2003، و تطلب الاستعانة بتدخل دعم فني خارجي من كل من شركة الاستضافة و شركة الاي بي و التنسيق مبينهما و اضطررنا اثناء الفترة الماضية الي توفير نسخ خارجي مستمر و سيرفر اضافى خارجي بالكامل ليتم من خلاله العمل على مايزيد على 10 نسخ احتياطية من ملفات الموقع تم حفظها منذ بدء المشاكل حيث مساحة السيرفر الحالي لا تسمع بذلك كسيرفر سحابي حيث ان الموقع به حالاي ما يقارب التسعين الف ملف مرفوع ، و هذا ليتم مقارنتها و استعادة ما فقد منها حيث تبين ان هناك خطا فى سكريبت الترقية ادي لاخطاء فى تسجيل المرفقات فى قواعد البيانات و آخر أدي لاعادة التسمية لبعض الملفات ، و عند الاصلاح تم تنفيذ سكريبتات لم تعمل بصورة مثالية مما اداي لحذف بيانات اخري و دخلنا فى دوامات متتالية مثلت ضغطاً كبيراً لحرصنا على الحفاظ على كل مشاركة اضافها الاخوة و كان من الممكن الترجع و فقدا بعض المشاركات و بداية الترقية من جديد ، و لكن هذا ايضا لم نقبله. النتسيق مع فريق الدعم للشركة فى امريكا لم يكن بالامر السهل لاختلاف التوقيت فكان اغلب نشاطهم فى توقيت النوم لدينا ، الخلاصة ان اللفترة الماضية كانت فترة عصيبة و تعرضنا فيها لمشاكل عديدة و ضغط عصبي كبير ، و اخر ما كنا نفكر فيه هو لون الخط ام ترجمة كلمة او التنسيق و ان كان قد تم الاستجابة مع كل ذلك لاغلب ما وصلنا من ملاحظات. بالتأكيد تشغيل هذه السكريبتات و استعادة و جذف الملفات كان له تأثير على سرعة الموقع فى حينه و قد حدث مرات عديدة مسح للكاش من قاعدة البيانات مما يؤدي لبطء عند التصفح و كون واجهة المستخدم تحتاج لعمل ريفريش لتعمل جيداٌ ، و اخيرا و لله الحمد تم مؤخرا استعادة كافة الملفات و اصلاح قاعدة البيانات و لذلك تم ارسال البريد الاخير طلبنا للمساعدة فى التحقق من المرفقات للتاكد من اكتمال المهمة بنجاح. و يبدو ان الامور حاليا على ما يرام بالنسبة للمرفقات. خلال هذه الفترة كان اسهل الحلول هو العودة للنسخة السابقة و فقدان المشاركات التي اضيفت بعد الترقية ، و لكن هذا بدا لي كمن يشتري حاضره بمستقبله ، و رفضت هذا الخيار شكلا و موضوعا لثقتي بما سيتحقق من فائدة مع مرور الوقت باذن الله تعالى. النسخة الجديدة تحتاج لنتعود عليها و نتعرف على امكانيتها و التي سيتم اكتشافها مع الوقت و هي فى نفس الوقت نقطة الانطلاق لتحديثات مستمرة من الشركة باذن الله سيكون فيها الكثير من الاضافات، فمن عاصر معنا النسخة السابقة فى بدايتها الي ان استقرت، كان التطوير و الاضافات ملموس مع كل ترقية. بينما السابقة هي نقطة نهاية مستقرة لاستخدام ثابت و لكن تعرضها للمشاكل مستقبلا اقرب لتوقف الدعم و التطوير بصورة نهائية. مثلا اي مشكلة تواجه مستخدم نتيجة انتقاله لويندوز 10 او ما سيليه او تحديث لاصدار متصفح مثل الاكسبلورر او جوجل او حتى صدور متصفح جديد مثل ايدج ستكون الشركة ملزمة بحلها لهذه النسخة اما السابقة فقد لا نجد لها حلاً لان تطوير النسخة قد توقف .ايضا عندما طرحنا بعض التعديلات للتغلب علي مشاكل اكتشفناها بالنسخة السابقة كانت الاجابة ببساطة نعتذر فقد توقف تطوير الجيل الثالث. اذا هناك ملاحظات محددة يرجى اضافتها فى الموضوع المخصص لذلك ملاحظات النسخة الجديدة - الاصدار الثاني لنعمل على تعديلها تباعا باذن الله او التواصل مع الشركة بشأن اضافتها فى الترقيات القادمة باذن لله

السلام عليكم ورحمة الله أخي الكريم يمكن استعمال الكود التالي في حدث الورقة : Private Sub Worksheet_SelectionChange(ByVal Target As Range) [Plage].Interior.Color = [B2].Interior.Color End Sub ألق نظرة على المرفق... أخوك بن علية المرفق : اللون.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 'وضع خط مرة أخري أسفل آخر قيم في ملف قاعدة بيانات 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

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