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

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

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

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

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

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

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

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

السلام عليكم تفضل الطابعة عند الضغط على الاسم_111.rar

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

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

الحمد لله أن هناك من يحس بألمنا شكراً يا عربي ...ألف شكر ... لا نكفيك حقك يا أخي.

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

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

السلام عليكم ورحمة الله مع أبو البراء لا تحتار جزاك الله خير

اخي أبا الحسن والحسين لو اخفينا العمود اللي فيه المعادله يعطي خطأ دخول كلمه المرور ياتري ماالسبب جاري تجربه الملف اخي مختار بس اكيد طبعا الملف هايكون صعيدي اصيل برضو

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

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

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

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

تفضل ابو يوسف المثال حسب فهمي اختر اسم المكتب من القائمة للفتح تقرير اجمالي مدارس حسب مكتب المختار SchoolR.rar

أخي الكريم أبو احمد بداية يرجى تغيير اللقب 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

جميع بيانات الملفات لشهر واحد حسب ملفاتك الحاليه ؟ اضفت في بعض الملفات اشهر وهميه بمعنى بيانات لـ 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 فائق إحتراماتي

السلام عليكم و رحمة الله و بركاته الي كل الاخوه بالمنتدى علينا جميعاً ان نقوم باستبدال اسماء المستخدمين الخاصه بنا من الانجليزيه الي العربيه والله المستعان

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

السلام عليكم ورحمة الله وبركاته ***************** هذا الموضوع تجميع لروابط الموضوعات التي قدمتها ، أسأل الله العلي القدير أن يجعل أعمالنا صالحة ولوجهه خالصة. افتح الباب وادخل لعالم البرمجة (متخافوش يا أحباب من اللي ورا الباب) استخراج كل الاحتمالات لأرقام محددة (موضوع الأسبوع الخامس) ترتيب الأسماء أو القيم طبقاً لطول السلسلة النصية (موضوع الأسبوع الرابع) عكس القيم في عمود أوقلب النتائج في عمود مجاور (موضوع الأسبوع الثالث) استخراج الصور من مصنف إكسيل حتى ولو كانت علامة مائية (موضوع الأسبوع الثاني) إخفاء كل الأعمدة ما عدا أعمدة محددة (موضوع الأسبوع الأول) وبضدها تتميز الأشياء (تجميعة Toggles) للشيء وعكسه الدالة MOD وعد الخلايا التي تحتوي على أرقام زوجية أو أرقام فردية حصرياً استخراج ملف فلاشي من داخل مصنف ليكون ملف منفصل بذاته أربعة عشر طريقة لمعرفة السنة الكبيسة أو السنة العادية باستخدام المعادلات طباعة أوراق عمل محددة حسب الاختيار مع إمكانية اختيار الطابعة وعدد النسخ منع التكرار في عمود ومنع نسخ أكثر من خلية بالعمود حصرياً دالة معرفة UDF لمعرفة الرقم التسلسلي للوحة الأم MotherBoard Serial إدراج أسماء الشهور بكل اللغات استخراج القيم الفريدة أي الغير مكررة في نطاق باستخدام الكائن القاموس إرسال إيميلات دفعة واحدة عبر الـ Outlook باستخدام برمجة الـ VBA تقسيم أو شطر قائمة واحدة إلى قائمتين بالتساوي جعل النص في أداة الـ Label يظهر بشكل رأسي عمل قائمة بأسماء الملفات في مسار محدد بالمعادلات بدون أكواد فورم لتوليد أرقام عشوائية ما بين رقمين مع الاحتفاظ بقيم البداية والنهاية في الريجستري إعلان عن خدمة برنامج السجلات المدرسية (البرنامج غير مجاني وليس للبيع) الحلقات التكرارية للمصفوفة تشغيل ملف صوتي بامتداد WAV عند تحديد خلية معينة بداية الطريق لإنقاذ الغريق إلغاء زر إغلاق التطبيق Excel Application Close Button إعادة ضبط نافذة محرر الأكواد الناموس في شرح القاموس استخراج القيم الفريدة أي الغير مكررة في نطاق باستخدام الكائن القاموس إضافة Addin تقوم بترتيب أسطر الكود (تنظيم الأكواد) المصفوفات في الإكسيل (نتعلم سوياً لنرتقي) - الحلقة الأولى المصفوفات في الإكسيل (نتعلم سوياً لنرتقي) - الحلقة الثانية تقليل حجم ملف الإكسيل (موضوع للبحث) تقسيم بيانات صف إلى عدة أعمدة إظهار المعادلات بدون أكواد معرفة الأرقام الناقصة Missing Numbers في سلسلة أرقام تصفية البيانات من خلال مربع نص TextBox (بحث بالأحرف الأولى والتصفية حسب البحث) استخراج القيم الغير مكررة مع إمكانية ترتيب القيم Sort أكواد البداية والنهاية لـ (ياسر بن خليل) البحث المتعدد وتلوين كلمات البحث باستخدام فورم استخراج القيم الغير مكررة في نطاق وعدها عن طريق دالة معرفة دالة معرفة UDF Function تقوم بإظهار المعادلات عمل طريق مختصر Shortcut على سطح المكتب للمصنف عن طريق الأكواد نسخ صورة لنطاق وعمل ارتباط للصورة بهذا النطاق إضافة شريط أمر تحكم إلى قائمة الكليك يمين تشغيل الماكرو عدد معين من المرات نسخ أو تحميل صورة من الويب إلى الإكسيل توليد تواريخ عشوائية بين تاريخين إغلاق المصنف بدون حفظ وإعادة فتح المصنف من جديد كيفية تصميم شيت الكنترول (ناصر سعيد) استخدام دوال الإكسيل WorksheetFunction التعامل مع الأنواع المختلفة للبيانات باستخدام SpecialCells مقارنة عمودين باستخدام التنسيق الشرطي إدراج رسم بياني في تعليق منع طباعة أوراق العمل كسر حماية أوراق العمل (القنبلة الجديدة) كسر حماية محرر الأكواد بدون برامج (قنبلة الموسم) إنشطار البيانات المفلترة (موضوع متميز بإذن الله) إنشاء تبويب مخصص Custom Tab إخفاء محتويات الخلايا (حيلة بسيطة) إظهار وإخفاء النطاقات المعرفة Defined Names داونلود مانجر من خلال الإكسيل ..حمل ملفاتك بالإكسيل ثلاثة طرق لتحديد أوراق العمل بالأكواد الملف القاتل (ملف يحوي كود لحذف أي ملف تحدده) فحص الاتصال بالانترنت عن طريق الأكواد التصفية المتقدمة بالأكواد Advanced Filter نسخ كود من مصنف لمصنف آخر ، ومن مصنف للمنتدى البحث عن جزء من النص باستخدام الدالة VLOOKUP (موضوع خفيف) دالة استخراج بيانات الرقم القومي (المحافظة والنوع وتاريخ الميلاد) دمج أوراق العمل من مصنفات مختلفة إلى مصنف واحد (المجمع) الإنشطار الكبير .. انشطار أوراق المصنف إلى مصنفات منفصلة نسخ البيانات بأكملها من ورقة عمل لورقة عمل أخرى دالة DatePart للتعامل مع أجزاء الوقت والتاريخ فتح مستند نصي ببرنامج الورد من داخل الإكسيل تجميع القيم مع كل إدخال جديد في نفس الخلية Accumulator عمل خريطة لورقة العمل Quick Map معرفة دقة الشاشة Screen Resolution دالة معرفة UDF لاستخراج الإيميلات داخل نصوص Emails From Text دالة معرفة UDF لتوليد أرقام عشوائية غير مكررة (فريدة) دالة معرفة UDF لدمج النصوص بمزايا مختلفة عن الدالة CONCATENATE دالة معرفة UDF لجمع الخلايا ذات التنسيق Bold (عريض) تغيير اسم ورقة العمل تبعاً لتغير قيمة خلية أوتوماتيكياً إنشاء القوائم المنسدلة (دروس للمبتدئين) معرفة الصف الأخير وإنشاء نطاقات ديناميكية غير ثابتة باستخدام الأكواد تغيير خصائص القائمة المنسدلة بإدراج كومبوبوكس إضافة الدوائر الحمراء وحذفها معرفة إذا ما كانت الخلية تحتوي على معادلة أم لا (بدون أكواد) المشروع الكبير (مكتبة الصرح .. زاخرة بالشرح) وهي عبارة عن تجميع لمكتبة الأكواد بشرى لمدخلي البيانات في موقع وزارة التربية والتعليم ادخل الموقع بنقرة واحدة تغيير أسماء أرقام سور القرآن الكريم إلى أسماء تلك السور الحفظ التلقائي كل 10 ثواني البحث عن القيم المتعددة بدون تكرار الخاصية Offset ف لغة البرمجة ألغاز إكسيلية (موضوع ترفيهي) عمل قائمة منسدلة يمكنك البحث من خلالها استخراج القيم بدون الخلايا الفارغة استخراج القيم بدون الخلايا الفارغة (دالة معرفة) تحديد صف وعمود الخلية النشطة (تلوين العمود والصف باستخدام التنسيق الشرطي) برنامج صغير للترجمة (ترجم من اللغة العربية للغة الإنجليزية) إنشاء أوراق عمل وفرزها وحذفها وضع علامة صح بمجرد النقر المزدوج في الخلية إضافة رائعة للإكسيل تقوم بفصل البيانات تقويم للسنة المقبلة 2015 دالة لإدراج صورة الخاصية Resize في لغة البرمجة دالة لعد التواريخ البحث عن الخلايا المدمجة بطرق مختلفة معرفة الوقت الذي تم فيه الدخول على الحاسوب انتحار ملف الإكسيل Kill This Workbook (Suicide) الخلية النابضة (من روائع الأعمال) العدسة المكبرة بالاكواد (من روائع الأعمال) الحلقة التكرارية FOR......Next استخدام الدالة DIR في محرر الأكواد للفيجوال بيسك إنشاء تقويم ميلادي بالأكواد المصفوفات في الإكسيل Arrays دالة تحويل التاريخ الهجري إلى ميلادي الحصول على قيم غير مكررة في قائمة التحقق التحقق من الصحة عمل اختصار للأمر في القائمة المختصرة دالة العد المتعددة والشاملة معرفة آخر يوم لأي يوم من أيام الأسبوع لأي شهر من شهور السنة ( موضوع مميز ) استخراج الأسماء المكررة في قائمة دالة معرفة لاستخراج تاريخ الميلاد والنوع ومحافظة الميلاد من الرقم القومي كود برمجي لفتح وغلق الـ CD-ROM قائمة بأسماء أوراق العمل دورة للمبتدئين في عالم البرمجة السلاسل النصية إدراج صورة في تعليق ************************* دمتم في رعاية الله

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

السلام عليكم صراحة احببت ان اضع هذا الموضوع منفردا بالرغم من ان هناك مشاركة سابقة لهذا الموضوع علي الرابط التالي اضغط هنا الا ان الموضع هنا قد اكتمل و اصبح لابد من فصله و الموضوع كما اشار العنوان ارجو التجربة و اخباري بالنتيجة تحياتي full_customer.rar

الأخ الفاضل / أحمد فضيله أحييك على هذه الدعوة وأضم صوتى الى صوتك

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

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

سابعا : حماية و أمان برنامج تثبيت نظام المستخدمين آليا عمل نظام صلاحيات المستخدمين برمجيا مسائل متنوعة في صلاحيات المستخدمين طريقة استخدام الكراك لتسجيل البرنامج - منع التعديل بصيغة mde - و مسائل متقدمة في الحماية اسلوب الحماية بالدونجل طريقة اخفاء و اظهار الاستعلامات بالكود كود لاخفاء الجداول الفعلية و المرتبطة مثال آخر لاخفاء و اظهار الجداول بالكود الحماية بطريقة زرع ملف