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

جرب هذه المعادلة في الخلية H3 واسحب يميناً حتى الخلية V3 و نزولاً =MID($B3,COLUMNS($H$3:H3),1)

تفضل ال mid مدموجة مع vlookup دالة VlookUp.rar الmid وحدها لن تكفي في حالتك نفترض ان البيانات تتغير ونريد معرفتها عن طريق الvlookup فدمج الاتنين معا يفي بالغرض حيث يتم استدعاء الكلمة عن طريق الvlookup وتقوم الدالة mid بعرض ما قمنا بتحديده فقط وشكرا

تفضل حبيبي ابو يوسف =MID($B3;1;1) =MID( المصدر; رقم الحرف; عدد حروف الظهور) واشوفلك باذن الله موضوع الvlookup دالة VlookUp.rar

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

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

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

أخي الكريم أبو فيصل م جرب الملف التالي عله يفي بالغرض Comments In Charts.rar

السلام عليكم إخواني الكرام كل عام وأنتم بخير ... أقدم لكم دالة تقوم بالتحويل من التاريخ الهجري إلى الميلادي Function ConvertDate(ByRef StringIn As String) As String Dim SavedCal As Integer Dim d As Date Dim s As String SavedCal = Calendar Calendar = 1 d = CDate(StringIn) Calendar = 0 s = CStr(d) ConvertDate = Format(s, "dd/mm/yyyy") Calendar = SavedCal End Function لمزيد من التفاصيل يرجى زيارة الرابط التالي رابط الموضوع من هنا

السلام عليكم ورحمة الله وبركاته هدفيه للعاملين بالكنترولات المدرسيه ...... _ سجلات اعمال الكنترول كامله ... _ توزيع الملاحظين اليا على اللجان .... مع تحياتى ....

اخواني الكرام بعد التوكل على الله ثم الاستشارة وحسب رغبة بعض الاخوة نبداء على بركة الله هذه الدورة شروط الدورة: تقتصر الدورة على شرح الفيجول بيسك للتطبيقات VBA ولا علاقة للمعادلات بهذه الدورة لذا نرجو ان يقتصر السؤال والاستفسار حول الاكواد فقط. عدم إضافة عبارة الشكر (نشكر الجميع على تقدير الجهود) حتى لا يحتاج الموضوع الى تنقيح فإن أعجبك شرح أو رد يمكنك تقييمه من خيار أعجبني شكراً. ان يكون موعد الاستفسارات حول الجزء المطروح للشرح خلال 24 ساعة فقط ويتم الانتقال الى جزء أخر لتعميم الفائدة. سيكون الشرح بشقين كتابي ومرئي. على الاساتذة الذين يشاركون في الشرح اخذ الشرط الثالث بالاعتبار (مشكورين). * سيتم حذف أي مشاركة لا يتم التقيد فيها بالشروط. == تم نقل جميع مشاركات النقاش الى هنا =============================== دروس الدورة ============================= الدرس الاول1 الدرس الاول2 الدرس الثاني الدرس الثالث الدرس الرابع 1 الدرس الرابع 2 الدرس الرابع 3 اساسيات لغة VBA كلغة برمجة (نظري) الفصل الثالث ج1 الفصل الثالث ج2 اسئلة الدورة (الجزء الاول)

السلام عليكم ورحمة الله وبركاته إخواني الأحباب في المنتدى المحبب إلى قلوبنا .. أقدم لكم اليوم شرح فيديو ، لكيفية عمل تصفية متقدمة Advanced Filter بالأكواد .. . والشرح مقدم في عدد 2 فيديو .. الأول لكيفية إدراج موديول وكتابة الأسطر الخاصة بتنفيذ التصفية المتقدمة ، والفيديو الثاني لكيفية تنفيذ الكود بدون أزرار بمجرد التغير في ورقة العمل أو التغير في شروط التصفية .. رابط الفيديو الأول : التصفية المتقدمة بالأكواد رابط الفيديو الثاني ومرفق لكم ملفين ..الملف الأول Advanced Filter VBA خاص بالفيديو الأول ، والملف المسمى Advanced Filter Worksheet_Change خاص بالفيديو الثاني أرجو أن ينال الدرس إعجابكم ، وتستفيدوا منه ولا أنتظر منكم سوى دعوة بظهر الغيب ، وادعوا الله لي أن يجعل أعمالنا صالحة ولوجهه خالصة ، وأن يجعل أعمالنا في ميزان حسناتنا يوم القيامة ، إنه ولي ذلك والقادر عليه كان معكم أخوكم أبو البراء من منتدى أوفيسنا (دي القفلة بتاعتي لو تلاحظوا .. مش شعبان عبد الرحيم بس اللي عنده القفلة !) حمل الملف من هنا

ودى فكرتى المتواضعة للوصول للنتيجة المطلوبة مع إضافة كود حدث قبل التحديث للفورم لو رقم الملف خالى او الاسم خالى لا يتم حفظ البيانات في الجدول حتى لا يتم احتساب بيانات غير كاملة program- UPDATE.rar وده تعديلى باظهار الرسالة التي تفيد وتوضح رقم الملف السابق ان وجد بالاسم الذى تم اضافته لرقم الملف هذا في رسالة بعد تحديث رقم الملف واهم شيء إضافة اللمسة الرمهانية على التعديل program- UPDATE2.rar

حاجة جميلة جدا

تفضل أخي محمود ملفك بعد التعديل program.rar

السلام عليكم تفضل اخي ما تريد لكن سامحني التنبيخ لم يعمل قد يستطيع احد مساعدتك في ذلك لكن اذا تم الضغط على الزر اكثر من مرة لا يؤثر على المجلد اذا كان منشأ مسبقا program.rar

السّلام عليكم و رحمة الله و بركاته أخي الكريم " رميلي كمال " .. كمحاولة منّي بمعرفتي المحدودة لفهم المشكلة .. لاحظ لو سمحت عمود الأعمال التّطبيقيّة بورقة Trim 1 .. قمت بوضع علامة تجريبة باللّون الأحمر : نذهب الآن لورقة Bulletin ..لاحظ الأسهم بالأحمر ..الخانة المقابلة للعلامة التي وضعتها بالصّورة الأولى فارغة .. و السّهم الثاني لملاحظة المعادلة الموضوعة .. لاحظ ذلك بهذه الصّورة رقم 2 : ستلاحظ أنّ اسم الورقة بالمعادلة أعلاه هو Feuil2 .. ندخل الآن لمحرّر الأكواد سنكتشف أنّ اسم الورقة Trim 1 والتي هي مصدر البيانات هو Feuil5 لاحظ الصّورة رقم 3 لو سمحت .. نغيّر اسم الورقة Feuil2 بالمعادلة إلى اسمها الرّسمي و الحقيقي و الذي هو Feuil5 و سترى علامات الأعمال التّطبيقيّة قد ظهرت بالورقة Bulletin مثلما تتمنّاه .. أخي الكريم .." رميلي كمال " .. أقول و أكرّر هذا اجتهاد منّي فقط ..لأنّ معرفتي جد محدودة بعالم الاكسل ..قد يكون كل ذلك بالصّدفة ..فلا تؤاخذني إن أخطأت بتفسيراتي فائق إحتراماتي

تعديل على الكود ليظهر كل مجموعة بلون واحد Sub cond() Dim lr As Integer lr = Cells(Rows.Count, 1).End(3).Row Range("a1:c" & lr).Interior.ColorIndex = xlNo k = 3 For i = 1 To lr If Range("a" & i).Interior.ColorIndex <> xlNo Then GoTo 1 For j = i + 1 To lr If Range("a" & i) & Range("b" & i) & Range("c" & i) = Range("a" & j) & Range("b" & j) & Range("c" & j) Then Range("a" & i).Resize(1, 3).Interior.ColorIndex = k Range("a" & j).Resize(1, 3).Interior.ColorIndex = k End If Next 1: k = k + 1 Next End Sub

نحن واهلنا في كل مكان من المسلمين اللهم امين

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

السلام عليكم الحمد لله الشين شغال شوية الشومين شول.

السلام عليكم شكراً لك أخي الحبيب ياسر

جزاك الله خيراً يا أ.عبدالعزيز وفي ميزان حسناتك

السلام عليكم حط الاكواد التاليه في حدث الفورم Private Sub CommandButton1_Click() On Error Resume Next Dim Lis, c, cl, Lr, Cm Lr = Range("A13").End(xlDown).Row + 1 With Me.ListBox1 .AddItem For c = 0 To 5 cl = Choose(c + 1, 6, 1, 2, 3, 5, 4) Cm = Me.Controls("TextBox" & cl) .List(UBound(.List), c) = Cm Range("A" & Lr).Offset(0, c) = IIf(IsNumeric(Cm), Val(Cm), CStr(Cm)) Me.Controls("TextBox" & cl) = "" Next c Mx End With On Error GoTo 0 End Sub Private Sub UserForm_Activate() Mx End Sub Private Sub UserForm_Initialize() Dim Rng As Range Set Rng = Range(Range("A13"), Range("A13").End(xlDown).Resize(1, 6)) Me.ListBox1.List = Rng.Value End Sub Private Sub Mx() Dim M M = Application.Max(Range("A:A")) + 1 TextBox6 = M End Sub

السلام عليكم هنا الكود يعطيك 3أسطر فارغة بين البيانات فإذا حبيت أن يكون الأسطر الفارغة هي 4بدلا من 3 فاذهب إلى السطر Range("A32:G34").Offset(32 * t, 0).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove وغير الرقم 34 إلى 35 تفضل المرفق تخفيف حجم الملف5.rar

السلام عليكم هل يوجد ضمن العمود A ايام غير محصوره بالنجمه * يعني ايام عشوائيه ليست منسقه بالسطر الاخضر ؟ ام اكيد ان كل مجموعة سطور ليوم معين يلييها سطر اخضر الخلاصه جرب الكود التالي ينفذ لك الدمج حتى اخر خليه في العمود A بها نجمه Sub Ali_Merg_Data() Dim R As Range Dim Rng As Range Dim My_r As Range Dim X_r As Double On Error Resume Next For Each R In Range("A6:A" & Ali_Last(Range("A6:A2000"), "*")) If R <> "*" Then If Not R Is Nothing Then If Rng Is Nothing Then Set Rng = R Else Set Rng = Union(Rng, R) End If End If Next R 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx If Not Rng Is Nothing Then For Each My_r In Rng.Offset(0, 9).Areas X_r = Alr_Cn(My_r) With My_r .ClearContents .Merge .Value = X_r End With Next End If On Error GoTo 0 Set Rng = Nothing: Set R = Nothing Set My_r = Nothing 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx End Sub Private Function Alr_Cn(R As Range) As Currency Dim i Dim Sm As Double With R For i = 1 To .Rows.Count Sm = Sm + .Cells(i, 1) Next i If Sm Then Alr_Cn = Sm End With End Function Private Function Ali_Last(Rnge As Range, F_Tx$) Dim vv Application.ScreenUpdating = False For vv = Rnge(Rnge.Count).Row To Rnge(1).Row Step -1 If Cells(vv, Rnge.Column) = F_Tx Then Ali_Last = vv Exit Function End If Next vv Application.ScreenUpdating = True End Function

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

السلام عليكم اضغط STEP1 ثم اختار اسم الورقة اضغط STEP2 ثم اختار اسم الإدارة التعليمية او المكتب اضغط STEP3 تظهر لك القائمة بالمدارس يمين الورقة و امامها عدد مرات التكرار تحياتي و تقديري school.rar

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

استدراك لتوضيح الأمور مطلوب الحصول على الاتى من قاعدة البيانات ان شاء الله ان يسر الله الامر لانشائها 1- بيانات شاملة للمريض 2-حجز مسبق للمريض بحيث لا يتعارض الحجز المحدد لاحد المرضى في يوم معين وساعة محدده لحين انتهاء عدد الجلسات التي يتم تحديدها مع مريض اخر مثال المريض xx محدد له 12 جلسة وايام جلساته تكون يومى الاحد والأربعاء الساعة 10 صباحا المطلوب عند حجز جلسات لمريض vv لا تتعارض مع المريض xx في الأيام في نفس الساعة مثل ما هو موضح فى الجدول التالى مثلا 3-تقرير سنوي عند عدد جلسات كل مريض على حده 4-تنظيم دخول المرضى حسب الغرف الشاغرة اى يتم التحكم والكنترول من قاعدة البيانات حتى في دخول وخول المرضى عن طريق معرفة الغرف ان كانت شاغرة ام لا

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

شفت شاب شيك شايل شنطه شيك شبه شنطه شارلي شابلن بس خلاص

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

تم معالجة الأمر من جديد كشف حساب salim 2.zip

أخي الكريم أبو احمد بداية يرجى تغيير اللقب 172426 إلى لقبك لنتعارف عليك بالنسبة للحلول التي قدمت ، قدمت على أساس مرفق .. للأسف وأكرر للأسف يحدث هذا الخطأ مع كثير من الأعضاء (راجع التوجيهات) ..أن يرفق ملف غير معبر عن الملف الأصلي يراعى مستقبلاً أن يكون الملف المرفق معبر عن الملف الأصلي تماماً حتى تتضح الصورة للجميع وحتى يكون العمل أسرع وأدق لا تنزعج من نصحي ..فما أردت لك ولغيرك إلا المصلحة الآن يعتبر الموضوع مختلف لأن المرفق سيكون مختلف عن سابقه .. لذا (وإن كنت أفضل طرح موضوع جديد) لذا ارفق ملفك الجديد المعبر عن الملف الأصلي .. وأكرر لا تنزعج من نصحي فوالله لا أريد إلا المصلحة والمنفعة للجميع ويرجى الإطلاع على رابط التوجيهات في الموضوعات المثبتة في صدر المنتدى تقبل تحياتي

اخي العزيز، انا ليش ما تشتغل معي الرجاء الرد في اقرب وقت واعطيلي الفيس بوك بتاعك لكي اتحدث معك

السلام عليكم المرفق الاول شرح طريقة العمل عليه والمرفق الاخر الملف وبه تعديل بعض الاخطاء البحث بالتاريخ لن يعمل معك اكتب التاريخ في الورقة "الصفحة 01" بالصيغة الصحيحه وسيعمل معك لاني ملاحظ مكتوب 01/01/00 ؟ توضيح.rar تجربة_112.rar

السلام عليكم انسخ الكود التالي الى حدث الورقة المسماه "الصفحة 2" Private Const My_Rng_Adrs As String = "$A$3:$D$55000" Private Const Area_Prnt As String = "$C$7:$E$15" Dim Ar_1() As Variant Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Range("A7:A1000"), Target) Is Nothing Then MsgBox "" If Target <> Empty Then Dim Wr As Worksheet: Set Wr = Sheets("الصفحة 3") With Wr .Cells(7, 4) = Target .Cells(8, 4) = Target.Offset(0, 1) .Cells(9, 4) = Target.Offset(0, 2) .PageSetup.PrintArea = Area_Prnt .PrintPreview .Cells(7, 4) = "": .Cells(8, 4) = "": .Cells(9, 4) = "" End With Cancel = False Set Wr = Nothing End If End If End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$A$5" Then Range(Range("A7"), Range("D7").End(xlDown).Resize(1, 4)).ClearContents If Ali_Serch(CStr(Target), 1) = True Then Range("A7").Resize(UBound(Ar_1, 1), UBound(Ar_1, 2)) = Ar_1() End If Erase Ar_1 End If If Target.Address = "$C$5" Then Range(Range("A7"), Range("D7").End(xlDown).Resize(1, 4)).ClearContents If Ali_Serch(CDate(Target), 3) = True Then Range("A7").Resize(UBound(Ar_1, 1), UBound(Ar_1, 2)) = Ar_1() End If Erase Ar_1 End If If Target.Address = "$E$5" Then Range(Range("A7"), Range("D7").End(xlDown).Resize(1, 4)).ClearContents If Ali_Serch(CStr(Target), 4) = True Then Range("A7").Resize(UBound(Ar_1, 1), UBound(Ar_1, 2)) = Ar_1() End If Erase Ar_1 End If End Sub Private Function Ali_Serch(Trget As String, Col As Long) As Boolean Dim Ar Dim Rng As Range Dim C, x, i, XX, Xi, Xt Dim Data_1 Dim Wrsh As Worksheet Set Wrsh = Sheets("الصفحة 01") With Wrsh If Col = 3 And Not IsDate(Trget) Then MsgBox "صيغة التاريخ التي كتبتها غير صحيحه !!", vbExclamation, "إدخال خاطئ !!": Exit Function Set Rng = .Range(My_Rng_Adrs) Ar = Rng.Value ReDim Preserve Ar_1(1 To Rng.Rows.Count, 1 To 4) For x = LBound(Ar, 1) To UBound(Ar, 1) XX = Ar(x, Col): Xi = Trim(Ar(x, 1)): Xt = Trim(Ar(x, 2)) If Col = 3 Or Col = 4 Then Data_1 = Val(XX) ElseIf Col = 1 Then Data_1 = CStr(Xi & " " & Xt) ElseIf Col = 3 Then Data_1 = CDate(DateSerial(Year(XX), Month(XX), Day(XX))) End If If Not Data_1 = Empty Then If Data_1 Like Trget Then Ali_Serch = True i = i + 1 For C = 1 To 4 Ar_1(i, C) = IIf(C = 3, Format(Ar(x, C), "dd/mm/yy"), CStr(Ar(x, C))) Debug.Print Ar(x, C) Next C End If End If Next x End With Set Rng = Nothing: Set Wrsh = Nothing End Function بعد كتابة الاسم او التاريخ او رقم التسجيل اضغط انتر ستظهر النتائج اسفل جدول البحث انقر مرتين على نتيجة البحث في العمود "A" الاسم الاول سيطبع لك النتيجه جرب وابلغنا بالنتائج تحياتي تم اضافة المرفق وبه الكود اعلاه تجربة_111.rar

السلام عليكم ورحمة الله أخي الكريم عملت بما في ملفك المرفق، أي بمجرد اختيار الاسم من المنسدلة يتم طباعة البيانات حسب شيت "صفحة الطباعة"... أرجو أن يكون المطلوب... بن علية تجربة.rar

جميع بيانات الملفات لشهر واحد حسب ملفاتك الحاليه ؟ اضفت في بعض الملفات اشهر وهميه بمعنى بيانات لـ 6 اشهر جرب الكود التالي حط الملفات بنفس فولدر الملف الذي به الكود Sub Ali_Tran_Fil() Dim Pth As String Dim F_il As String Dim S_Nm As String Dim My_Vlu() As Variant Dim Lr, Lrr, R, Dy, Ar, Az, Ar_O, ii, rr, pp, Cr Dim Date_M As Date Dim O_Wp As Workbook Dim ws As Worksheet Dim Sh As Worksheet Dim Mi_A As Worksheet Dim sht As Worksheet Set Mi_A = Sheets(1) De_Sht CStr(Mi_A.Name) Apc_Ali False '-------------------------------------------------------------------- Pth = ThisWorkbook.Path & "\" '' مسار الملفات بنفس مسار الملف الحالي '-------------------------------------------------------------------- F_il = Dir(Pth & "*.xlsx") '' xlsx صيغة ملفات الاكسل التي سيتم جلب بياناتها '-------------------------------------------------------------------- ReDim Preserve My_Vlu(1 To 10000, 1 To 6) '-------------------------------------------------------------------- Do While F_il <> "" If F_il <> ThisWorkbook.Name Then S_Nm = Pth & F_il Set O_Wp = Workbooks.Open(S_Nm) Set ws = O_Wp.Sheets(1) Lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row For R = 2 To Lr I = I + 1 My_Vlu(I, 1) = ws.Cells(R, 3) My_Vlu(I, 2) = ws.Cells(R, 1) My_Vlu(I, 3) = ws.Cells(R, 2) My_Vlu(I, 4) = ws.Cells(R, 6) My_Vlu(I, 5) = ws.Cells(R, 7) My_Vlu(I, 6) = Split(F_il, ".")(0) Next R O_Wp.Close False F_il = Dir End If Loop '-------------------------------------------------------------------- Mi_A.Range("A2").Resize(UBound(My_Vlu, 1), UBound(My_Vlu, 2)) = My_Vlu '-------------------------------------------------------------------- Mi_A.Sort.SortFields.Add Key:=Mi_A.Range("D2", Mi_A.Range("D2").End(xlDown)), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With Mi_A.Sort .SetRange Mi_A.Range("A2:F" & Mi_A.Range("A1").End(xlDown).Row) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With '-------------------------------------------------------------------- With CreateObject("scripting.dictionary") For ii = LBound(My_Vlu, 1) To UBound(My_Vlu, 1) If My_Vlu(ii, 1) <> "" Then If IsDate(My_Vlu(ii, 4)) Then Date_M = My_Vlu(ii, 4) Dy = .Item(Month(Date_M)) End If End If Next ii Ar = Split(Join(.Keys, ","), ",") End With '-------------------------------------------------------------------- For rr = LBound(Ar) To UBound(Ar) If IsError(Evaluate("'" & Ar(rr) & "'!A1")) Then Set Sh = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count)) With Sh .Name = CStr(Ar(rr)) Az = Array("رقم العميل", "العدد", "الصنف", "التاريخ", "السعر", "إسم الملف") With .Range("A1") .Offset(0, 0).Resize(1, UBound(Az) + 1) = Az End With .Columns(1).ColumnWidth = 29.29 .Columns(2).ColumnWidth = 8.43 .Columns(3).ColumnWidth = 15 .Columns(4).ColumnWidth = 16.14 .Columns(5).ColumnWidth = 8.43 .Columns(6).ColumnWidth = 8.43 End With End If Next rr '-------------------------------------------------------------------- Ar_O = Mi_A.Range("A1").CurrentRegion.Value For Each sht In Sheets If Not sht.Index = 1 Then For pp = 1 To UBound(Ar_O, 1) If IsDate(Ar_O(pp, 4)) Then If Trim(Month(Ar_O(pp, 4))) = Trim(sht.Name) Then With sht Lrr = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row .Cells(Lrr, 1) = Ar_O(pp, 1) .Cells(Lrr, 2) = Ar_O(pp, 2) .Cells(Lrr, 3) = Ar_O(pp, 3) .Cells(Lrr, 4) = Ar_O(pp, 4) .Cells(Lrr, 5) = Ar_O(pp, 5) .Cells(Lrr, 6) = Ar_O(pp, 6) End With End If End If Next pp End If Next sht '**** Sh_S '**** '\\\\\\\\ Cr = Split(Mi_A.UsedRange.Address, "$")(4) Mi_A.Range("A2:F" & IIf(Cr = 1, 2, Cr)).ClearContents '//////// Apc_Ali True '************************************ Set O_Wp = Nothing: Set ws = Nothing Set Sh = Nothing: Set Mi_A = Nothing Set sht = Nothing: Erase My_Vlu End Sub Private Sub B_Set(Sh_N()) Dim T_m Dim I, J '---------------------------------- Apc_Ali False For I = LBound(Sh_N) To UBound(Sh_N) For J = I To UBound(Sh_N) If Sh_N(I) > Sh_N(J) Then T_m = Sh_N(I) Sh_N(I) = Sh_N(J) Sh_N(J) = T_m End If Next J Next I Apc_Ali True '---------------------------------- End Sub Private Sub Sh_S() Dim Sht_a As Worksheet Dim My_Sh() Dim I '------------------------------------------ Apc_Ali False ReDim My_Sh(ThisWorkbook.Worksheets.Count) I = LBound(My_Sh) For Each Sht_a In ThisWorkbook.Worksheets My_Sh(I) = Sht_a.Name I = I + 1 Next Sht_a '----------- B_Set My_Sh '----------- For I = LBound(My_Sh) + 1 To UBound(My_Sh) If Sheets(My_Sh(I)).Index <> 1 Then Worksheets(My_Sh(I)).Move After:=Worksheets(ThisWorkbook.Worksheets.Count) End If Next I Apc_Ali True '------------------------------------------ End Sub Public Function De_Sht(ByVal Nm_S As String) Dim Sh_D As Worksheet ''------------------------------------ For Each Sh_D In Worksheets Application.DisplayAlerts = False If Sh_D.Name <> Nm_S Then Sh_D.Delete Application.DisplayAlerts = True Next Sh_D ''------------------------------------ Set Sh_D = Nothing End Function Public Function Apc_Ali(Bll As Boolean) ''------------------------------------ With Application .Calculation = IIf(Bll, -4105, -4135) .ScreenUpdating = Bll .EnableEvents = Not Bll End With ''------------------------------------ End Function والمرفقات الملف وبه الكود new_Ali.rar

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

إخواني الكرام إليكم الملف يعمل على النسختين 32 بت و 64 بت أرجو أن تستفيدوا منه .. تقبلوا وافر تقدير واحترامي Codes Library v1.9.7.rar

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله أقدم لكم اليوم كيفية فتح مستند نصي (مستند ورد) عن طريق فتح تطبيق الورد من داخل الإكسيل .. في الملف المرفق يوجد ملف إكسيل وملف ورد لعمل اختبار عليه .. قم بفك الضغط عن الملف المرفق على سطح المكتب مثلاً عند الضغط على زر الأمر في ورقة العمل ، سيقوم الكود بفتح صندوق حواري (مستعرض الملفات) لتقوم بتحديد مكان أو موقع المستند الذي تريد فتحه .. قم بالذهاب إلى مسار المستند وقم بتحديده ثم اضغط Open لفتح الملف .. إذا لم يتم اختيار ملف ستظهر رسالة تفيد بذلك .. يوجد أيضاً دالة معرفة داخل الموديول تقوم بفحص ما إذا كان الملف مفتوح أم لا ، فإذا كان الملف مفتوح مسبقاً يتم الخروج من الإجراء الفرعي .. إذا أردت التخلص من الدالة وتقليل حجم الكود قم بمسح الدالة Function (الجزء الثاني في الموديول) كما قم بمسح هذا السطر من الكود If IsFileOpen(Sheet1.Range("A1").Value) Then Exit Sub هذا السطر تمت إضافته لفحص الملف إذا ما كان مفتوح أم لا ..لأنه في حالة إذا كان الملف مفتوح مسبقاً وقمت بفتحه مرة أخرى ، سيتسبب ذلك في بطء عمل الكود ، وينتهي برسالة خطأ .. شكل الكود المسئول عن فتح المستند ببرنامج الورد Sub Browse() 'تعريف المتغيرات '---------------- 'تعريف المتغير الذي سيأخذ قيمة مستعرض الملفات Dim strFileToOpen 'تعريف المتغير الذي يشير إلى إنشاء كائن تطبيق الورد Dim objWord 'تعريف المتغير الذي يشير إلى المستند النصي Dim objDoc 'نافذة المستعرض '-------------- 'تعيين قيمة المتغير ليساوي قيمة نافذة مستعرض الملفات ، والذي يمثل مسار المستند الذي يتم اختياره strFileToOpen = Application.GetOpenFilename(Title:="Please Choose A File To Open", FileFilter:="Word Files *.doc* (*.doc*),") 'اختبار اختيار المستند '--------------------- 'إذا لم يتم اختيار مستند يتم إظهار رسالة تنبيه ثم الخروج من الإجراء الفرعي If strFileToOpen = False Then MsgBox "لم يتم اختيار ملف", vbExclamation, "تنبيه" Exit Sub 'إذا كان المستند مفتوح يتم الخروج من الإجراء الفرعي Else 'تساوي قيمة نافذة مستعرض الملفات [A1]الخلية 'يتم وضع مسار المستند بالكامل في الخلية Sheet1.Range("A1").Value = strFileToOpen 'إذا كان المستند مفتوح مسبقاً يتم الخروج من الإجراء الفرعي If IsFileOpen(Sheet1.Range("A1").Value) Then Exit Sub 'تعيين قيمة المتغير ليساوي تطبيق الورد Set objWord = CreateObject("Word.Application") 'تعيين قيمة المتغير ليساوي المستند الذي سيتم فتحه بتطبيق الورد Set objDoc = objWord.Documents.Open(strFileToOpen) 'إظهار تطبيق الورد objWord.Visible = True End If End Sub والدالة المسئولة عن عملية فحص الملف ما إذا كان مفتوح أم لا Function IsFileOpen(filename As String) '[False]أو إلى[True]هذه الدالة تقوم باختبار إذا ما كان الملف مفتوح مسبقاً وترجع القيمة إما إلى Dim filenum As Integer, errnum As Integer On Error Resume Next 'هذا السطر لتجنب رسائل الخطأ filenum = FreeFile() 'الحصول على رقم للملف 'محاولة فتح الملف ثم إغلاقه Open filename For Input Lock Read As #filenum Close filenum 'إغلاق الملف errnum = Err 'حفظ رقم الخطأ الذي يحدث On Error GoTo 0 'استعادة خاصية رسائل الخطأ 'فحص رقم الخطأ Select Case errnum 'في حالة عدم وجود خطأ ، إذاً الملف غير مفتوح Case 0 IsFileOpen = False 'الرقم 70 يعني أن الملف مفتوح وغير مصرح بالدخول عليه Case 70 IsFileOpen = True 'في حالة حدوث خطأ آخر Case Else Error errnum End Select End Function أترككم مع الملف .. ويوجد شرح لأسطر الكود دمتم في عز الله وطاعته Open Word Document.rar

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

السلام عليكم شكرا للاخ الكريم ssm على الاجابة وجزاه الله خيرا اخونا الشاعر : يمكن عمل ما تريد يدويا او بالاستعانة بالكود البرمجي شريطة ان تكون خصيصة : توسيط تلقائي=لا اما يدويا فكما ذكر اخونا ssm ففي عرض التصميم اسحب النموذج في المكان المحدد الذي تريد ان يظهر فيه ثم احفظ اما الكود البرمجي فضع هذا السطر في حدث فتح النموذج Me.Move Left:=3000, Top:=6000 وغير في الارقام حسب رغبتك

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

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

السلام عليكم هذا الكود تحطه في حدث THISWORKBOOK Private Sub Workbook_Open() For Each sh In ActiveWorkbook.Worksheets S_ALI = S_ALI & "," & sh.Name Next sh Range("A1").Select With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=S_ALI End With End Sub وهذا في حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Range("A1")) Is Nothing Then Worksheets(Target.Value).Select End If End Sub وهذا المرفق SH_DATA.rar

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

ممكن سؤال اذا سمحت يا استاذ نادر ياترى اقدر اغير الباسوورد ولا لا؟ واذا كان ممكن اعمل ده ازاي؟؟؟؟؟؟ شكرا

12/11/2009 طريقة عمل البرنامج 1- تسجيل بيانات العميلالدخول الى صفحة العملاء و تسجيل بيانات العميل - غير قابل لتكرار اسم العميل 2- توزيع الأقساطالدخول الى ورقة توزيع الأقساط ثم يتم ادخال البيانات كاملةبمجرد ادخال البيانات تظهر لك النتائج في الجدول الأيسر 3- اضغط على زر حفظ بيانات الأقساط - سوف يتم حفظ البيانات في ورقة الأقساط و منها تجد اجمالي المبالغ المطلوبة من العميل قد ظهرت في ورقة بيانات العملاء 4-الدخول الى ورقة السندادخل اسم العميل - سوف تظهر لك قائمة منسدلة بأسماء الأجهزة التي تم عمل اقساط لها لهذا العميل تختار منها الجهاز او السلعة المطلوبة بعد ادخال اسم العميل و نوع الجهاز تظهر لك قائمة منسدلة بـ أول قسطين مطلوب سدادهما من العميل تختار منها ماتريدتقوم بتسجيل المبلغ - و هنا تستطيع تسجيل أي مبلغ اقل من او يساوي قيمة القسط المختار او مطلوب سداده بعد اكتمال بيانات السند تختار طـبـاعة الـسـنـدبعد طباعة السند تلقائيا سوف يتم تسجيل المبلغ في العمود A امام العميل في ورقة توزيع الأقساط - ويتم حفظ كامل بيانات السند في ورقة حفظ البيانات السداد - الآن لدينا في ورقة بيانات العملاء عمود الأقساط المتأخرة - هنا يتم حساب كل الأقساط المطلوبة من هذا العميل قبل تاريخ اليوم و يخصم منها اجمالي المبالغ المسددة من العميل الآن تستطيع استخدام الملف و استخراج النتائج منه مع تحياتي للجميع 4_توزيع_الأقساط_ومتابعتهاQest.rar