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

وعليكم السلام أخي الكريم قم بتغيير اسم الملف المسمى بيانات العاملين 21-9-2023 إلى Employees DB أو قم بتغيير الاسم في الكود (كما يحلو لك) ضع الكود التالي في الملف المسمى الإدارة العامة Sub Test() Dim a, wb As Workbook, ws As Worksheet, sh As Worksheet, c As Range, dic As Object, sName As String, lr As Long Application.ScreenUpdating = False Set dic = CreateObject("Scripting.Dictionary") Set wb = Workbooks.Open(ThisWorkbook.Path & "\Employees DB.xls") Set ws = wb.Worksheets(1) Set sh = ThisWorkbook.ActiveSheet For Each c In ws.Range("C6:C" & ws.Cells(Rows.Count, "C").End(xlUp).Row) sName = c.Value If Not dic.Exists(sName) And sName <> Empty Then dic.Add sName, Array(c.Offset(0, 1).Value, c.Offset(0, 2).Value, c.Offset(0, 3).Value) End If Next c wb.Close SaveChanges:=False lr = sh.Cells(Rows.Count, "B").End(xlUp).Row sh.Range("E3:G" & lr).ClearContents For Each c In sh.Range("B3:B" & lr) sName = c.Value If dic.Exists(sName) Then a = dic(sName) c.Offset(, 3).Resize(, 3).Value = a End If Next c Application.ScreenUpdating = True End Sub

يمكنك إضافة خيارات اللغة إلى شريط الوصول السريع ملف --- خيارات --- تخصيص شريط الوصول السريع file - options - quick access toolbar أوامر غير موجودة في الشريط commands not in the ribbon هيارات اللغة options language إضافة add ok كما بالصورة بالتوفيق

السلام عليكم ورحمه الله تعالى وبركاته بعد إذن الأستاذ @أ / محمد صالح إليك حل آخر Private Sub Worksheet_Change(ByVal Target As Range) Dim WSdata As Range On Error GoTo EH Set WSdata = Me.Range("A:A") If Not Application.Intersect(WSdata, Target) Is Nothing Then Application.EnableEvents = False Select Case LCase(Target.Value) Case "done", "Done", "DONE" Me.Cells(Target.Row, 3) = Me.Cells(Target.Row, 2) Me.Cells(Target.Row, 5) = Date Case Is >= 0 Me.Cells(Target.Row, 3) = Empty Me.Cells(Target.Row, 5) = Empty End Select End If EH: Application.EnableEvents = True End Sub Test_Done.xlsb

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

أشكرك يا باشمهندس محمد ...ربنا يبارك فيك و يزيدك من نعيم الله

تفضل هل هذا ما تريد بالتوفيق قاعدة تجربة.accdb

جرب استعمال هذا الكود في حدث تغيير محتويات الشيت Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 Then If Target.Value = "done" Then Target.Offset(0, 2).Value = Target.Offset(0, 1).Value Target.Offset(0, 4).Value = Date End If End If End Sub بالتوفيق

عليكم السلام يمكنك فتح الملف ثم النقر فوق "ملف" و"فحص المصنف" File - Inspect Workbook وأصلح ما تجده من عيوب سيفتح معك بصورة طبيعية بعدها إن شاء الله بالتوفيق

اتفضل هذا الملف الخاص بك بعد التعديل كان لا بد لك ان تراجع الكود واذا لم تفهم الفكره تكت لكى نشرح لك الفكره لان الغرض هنا فى المقام الاول لهذا الصرح العظيم هو التعليم اولا ما قمت بعمله هو كالاتى جعلت جميع نوع البيانات فى الجدول من نوع نص قمت باضافة حقلين جدد وهو Other والمقصود منه Type بصراحة كسلت اعدلها ^_^ (اى نوع الفورم "هل هو نموذج ام تقرير") واضفة ايضا ObjName اسم العنصر (اسم الفورم الذى سوف يفتح من الشجرة) ثم قمت باضافة هذا الكود On Error GoTo HandleError Dim IDListObj, IDPriName As Double Dim strObjName, xOtheR As String 'هنا انا بحدد رقم المعرف للفورم من الشجرة لانه هيكون هو معياري IDListObj = Right(Me.TreeView2.SelectedItem.Key, Len(Me.TreeView2.SelectedItem.Key) - 1) ' IDPriName = Nz(DLookup("[Code]", "[Family]", "[ID] =" & IDListObj & "")) 'انا هنا بحاول اوصل لاسم الفورم او التقرير المسجل فى الجدول الخاص ب الاسم المسجل فى الشجرة strObjName = DLookup("[ObjName]", "[Family]", "[ID]=" & IDListObj & "") 'هنا انا محتاج اعرف نوع العنصر ال هيفتح هل هو فورم ولا تقرير xOtheR = DLookup("[Other]", "[Family]", "[ID]=" & IDListObj & "") ' MsgBox IDPriName & " - " & strObjName & " - " & xOtheR 'هنا الكود الخاص بعملية الفتح للنماذج او التقارير If strObjName = "Close" Then Select Case MsgBox(Buttons:=vbYesNo + vbQuestion, Prompt:="هل تريد غلق البرنامج؟", Title:="تنبيه!") Case vbYes DoCmd.Quit acQuitSaveAll Case vbNo Exit Sub End Select Else If xOtheR = "Report" Then DoCmd.OpenReport strObjName, acViewPreview ElseIf xOtheR = "Form" Then DoCmd.OpenForm strObjName, , , , , acDialog End If End If HandleExit: Exit Sub HandleError: If err.Number = 0 Then Exit Sub ElseIf err.Number = 94 Then ' MsgBox "لم يتم تسجيل اسم النموذج فى القائمه بعد؛؛؛" Exit Sub ElseIf err.Number = 2478 Then Exit Sub Else MsgBox err.Number & vbNewLine & vbNewLine & err.DESCRIPTION End If Resume HandleExit اخير اتفضل الملف بعد التعديل شجرة TREE.rar

تفضل التعديل حدد مكان وجود القالب و اسم و موقع حفظ الملف الجديد بهذا الشكل SendData.zip

لم تزودنا ببيانات اضافية للتجربة .... على العموم جرب المرفق عسى يفي بالغرض المطلوب ... وحاول تعديل الكود حسب بياناتك الاساسية لديك ... ‏‏مثال (4) - نسخة.accdb

On Error Resume Next Dim X As Worksheet Dim k As Integer Dim m As Date Dim n As Date ListBox1.Clear rng1 = CDate(TextBox9.Value) rng2 = CDate(TextBox10.Value) rng3 = ComboBox1.Text rng4 = ComboBox2.Text dfr = 0 For Each X In ThisWorkbook.Worksheets ss = X.Cells(Rows.Count, 2).End(xlUp).Row For i = 2 To ss If X.Cells(i, 6) Like "*" & rng3 & "*" And X.Cells(i, 4) Like "*" & rng4 & "*" And X.Cells(i, 2) >= rng1 And X.Cells(i, 2) <= rng2 Then ListBox1.AddItem ListBox1.List(dfr, 0) = X.Cells(i, 1) ListBox1.List(dfr, 1) = Format(X.Cells(i, 2), "dd/mm/yyyy") ListBox1.List(dfr, 2) = X.Cells(i, 3) ListBox1.List(dfr, 3) = X.Cells(i, 4) ListBox1.List(dfr, 4) = X.Cells(i, 5) ListBox1.List(dfr, 5) = X.Cells(i, 6) ListBox1.List(dfr, 6) = X.Cells(i, 7) ListBox1.List(dfr, 7) = X.Cells(i, 8) ListBox1.List(dfr, 8) = X.Cells(i, 9) ListBox1.List(dfr, 9) = X.Cells(i, 10) ListBox1.List(dfr, 10) = X.Cells(i, 11) '.Value ListBox1.List(dfr, 11) = X.Cells(i, 12) '.Value dfr = dfr + 1 End If Next i Next X Call Main Call Sort شكرا جزيلا ا/ محمد هشام لقد تم الحل ونسيت ان ارفقه

انا غيرت في المسميات في مثالك كانت الاسماء : نوع CRJ CRI BOEING BOENIG AIRBUS AIRBUS CRJ BOING ARBUS ويبدوا ان فيها اخطاء املائية في الاسماء الثلاث .. وانت قلت : ( انها ثلاث انواع ولكن الارقام تختلف) لذا قمت بتصحيح الاسماء لاحظ BOEING كلها مختلفة عن بعضها .. والبقية مثلها اذا هذه الاخطاء الاملائية موجودة عندك في الأصل وتريد تطبيق فكرتك فيلزمك التالي : عمل حقل يحمل صفة محددة واحدة لهذه الاسماء مثلا .. BOEING ثلاث اسماء مختلفة يجب ان تضع امامها رقما او نصا واحدا .. اي انك تجعلها متشابهه في الصفة ولنقل تضع امام كل واحدة رقم 1 وهكذا تعمل مع بقية الاسماء ... ويكون تطبيق الكود على هذه الصفة كيف تعرف ان الاسماء مختلفة ؟ اعمل استعلام تجميعي لحقل الاسم Group By من جدول TBL_T_TYPE_PLANE

وحماية ثالثة .. ان يحميك الله من كل سوء ، ويطيل عمرك على طاعته

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

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

يا استاذ @رولي اتفضل راجع الموضوع الاتى قمت بالتطوير على الاكواد لاضافاء مرونى فى التعامل مع الاصوات ذوات الامداد MP3 , WAV ودائما احاول قدر المستطاع عند كتابة الأكواد مراعاة التعامل مع كلتا النواتان 32x , 64x

لا اعتقد ان هيكون الموضوع بهذه السهوله اذا كانت قاعدة البيانات من النوع ACCDE (القاعدة التى سوف تفتح البرنامج "الواجهه") فهنا استحالة انه يوصل للكود حتى لو معه الباسورد ^_^ (عارف ان مفيس مستحيل لكن على الاقل هذا يتطلب مستوي عالى جدا من الخبره) وبما ان الواجهه نفسها مغلقه بكلمة سر (معقده) والخلفيه مغلقه بكلمة سر معقده ايضا فهيكون من شبه المستحيل كسرها والله اعلم

تفضل For K = LBound(DestArr) To UBound(DestArr) Worksheets(DestArr(K)).Activate derligne = ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row Rng = ActiveSheet.Range("A5:N" & derligne) sours = [L2] sours2 = [D2] For i = 1 To UBound(Rng, 1) If Rng(i, 1) > 0 And Rng(i, 2) > 0 And Rng(i, 1) <> "ت" Then y = y + 1: ReDim Preserve A(1 To UBound(Rng, 2) + 2, 1 To y) For F = 1 To UBound(Rng, 2) A(F, y) = Rng(i, F) Next With ws ws.[A2].Resize(y, UBound(A, 1)) = Application.Transpose(A) A(UBound(Rng, 2) + 1, y) = sours A(UBound(Rng, 2) + 2, y) = sours2 End With End If Next Next تجميع شيتات 7.xlsm

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

حل آخر Sub test() Dim a Dim i& a = Sheets("DATA").Cells(1).CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a) If a(i, 3) = Sheets("RESULT").Cells(1, 5) Then If Not .exists(a(i, 1)) Then .Add a(i, 1), Array(a(i, 1), a(i, 2), a(i, 3)) End If Next a = Application.Index(.items, 0, 0) End With With Sheets("RESULT").Cells(1).CurrentRegion.Offset(1) .ClearContents .Resize(UBound(a), 3) = a End With End Sub

مجرد تخمين Sub Button1_Click() Dim i As Long For i = Sheet1.Cells(Rows.Count, 3).End(xlUp).Row To 1 Step -1 If Sheet1.Cells(i, 3) = "ناجح" Or Sheet1.Cells(i, 3) = "راسب" Then Sheet1.Range("a" & i & ":c" & i).Copy Sheet3.Cells(Rows.Count, 1).End(xlUp).Offset(1) End If Next End Sub

استخدم الدالة COUNTIF ثم قم بفرز نتيجة الدالة واحذف المكرر المثال بالمرفق =COUNTIF(A:A;D2) المصنف1.xlsx

السلام عليكم مرفق حل بالمعادلات فقط (شرط ان لا تتكرر اسماء الدول فى السطر رقم 2) قوائم منسدلة ديناميكية.xlsx

إتفضل يا سيدى MultiSelectInContinuousForms (V3).mdb

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

جرب هذا التعديل ComboBox With Drop List_new.xlsm

ما شاء الله أخي خبور خير رائع وجميع أكواده بسيطة وفعالة أعاده الله لنا وسلمه من كل سوء ولإثراء الموضوع أقدم هذه المعادلة لنفس الغرض =INDEX($a$2:$a$1000,MATCH(0,COUNTIF($D$1:D1,$a$2:$a$1000),0)) حيث وجود البيانات في العمود a ويتم كتابة المعادلة في الخلية d2 مع الضغط على Ctrl+shift+enter لأنها معادلة صفيف array formula ثم تسحب لأسفل وفقنا الله جميعا للخير دمتم في رعاية الله وحفظه

‏الاحد‏ 18‏/6‏/1434هـ الموافق ‏28‏/4‏/2013م المختصر: يتم اخذ صورة من الماسح الضوئي الإسكنر و وضعها في ملف اكسل جديد وحفظ هذا الملف في المجلد الذي تحدده بالإسم الذي تحدده مع عمل ارتباط شعبي للملف الذي به الصورة لكي يسهل الوصول له. الشرح: في الملف المرفق اختار نوع المستند الذي تريد عمل صورة له من الماسح الضوئي وذلك من اعلى الصفحة الأولى للملف هوية او استمارة حدد المجلد الذي تريد حفظ الصورة به – بالضغط على زر تحديد مجلد الحفظ الموجود في اعلى الورقة من اليسار اكمل بيانات المستند المطلوب حفظة داخل الورقة أدخل الورقة او المستند المطلوب الى الماسح الضوئي ثم اضغط على صورة مسح ضوئي Scan الموجودة يمين الشاشة اتبع التعليمات التي تظهر – ادراج مخصص – ثم – معاينة – ثم – مسح ضوئي تتم الخطوات التالية تلقائيا ادراج الصورة في ملف اكسل جديد تعديل حجم الصورة اذاكانت كبيرة بحيث تطبع في ورقة واحدة حفظ الملف الجديد حسب البيانات التي ادخلتها في المجلد المحدد منك مسبقا وضع بيانات الصورة في جدول البيانات مع ارتباط شعبي لسهولة الوصول الى الملف الموجوده به الصورة البحث عن صورة: بالضغط على البيانات المسجلة يتم الدخول الى جدول به بيانات كل الصور التي تم عمل سكان لها من الخانة الصفراء اعلى الورقة اكتب أي جزء من معلومة تريدها يتم تصفية الصفوف بحيث تظهر الصفوف التي تحتوي على هذه المعلومة اضغط على المعلومة التي تريدها يتم فتح الملف الذي به الصورة بواسطة الإرتباط الشعبي شكر خاص الى كلا من Khhanna و Hancock و ابونصار عباد و شوقي ربيع http://www.officena.net/ib/index.php?showtopic=46533 http://www.officena.net/ib/index.php?showtopic=44394 ملحوظة للإخوة الذين يستخدمون اكسل 2007 او اكثر – اذا لم تظهر الأيقونات او الأزرار في أي ورقة فقط عدل زووم العرض من اسفل الشاشة يسار آمل ان يكون به الفائدة للجميع دمتم بخير Excel_Scan.rar

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

بعد أذن أساتذتى حل أخر تم تعديل المرفق لتتناسب المعادلة مع أوفيس 2007 عفوا فأنا أعمل على أوفيس 2003 تقبلوا تحياتى مقارنة قائمتين وأرجاع القيم الفريدة فى قائمة ثالثة (2003 -2007 ).rar

السلام عليكم و رحمة الله إستخدم هذه الطريقة اخي بجاني القائمة الأولى إستخدم المعادلة التالية =ISNUMBER(MATCH(ValInList1,List2,0)) طبعاً أخي الفاضل قم بتغيير ValInList1 بمرج الخلية المنوي البحث عنه و الـ List2 هي القائمة التي تريد البحث فيها إن كانت النتيجة True فمعناها أن القيمة موجودة ============ و أيضاً يمكنك إستخدام نفس المعادلة في التنسيق الشرطي حدد المجموعة الأولى و من خيارات Home Conditional Formatting New Rule Use a formula... إستخدم نفس المعادلة و إختر التنسيق الذي يناسبك أتمنى أن تكون الصورة واضحة دمت في حفظ الله

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

أخى الفاضل / عادل تفضل ما تريد الترتيب فى القائمه المنسدلة فقط داخل الفورم ( بمعنى عند فتح القائمه تكون مرتبة ) وليس فى ورقة الاكسل قائمة فرعية من قائمة رئيسية داخل فورم مرتبة أبجديا فى الفورم فقط.rar

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

السلام عليكم ورحمة الله وبركاته افكار رائعة جزاكم الله كل خير وللإثراء كون الموضوع بخصوص القوائم المنسدلة, في المرفق مثال لقائمة منسدلة مفلترة بالمعادلات . وهي ربما تكون مفيدة في حالة البيانات كبيرة. وعذرا اذا كان المثال خارج طلب صاحب الموضوع تحياتي قائمة منسدلة مفلترة.rar

السلام عليكم بارك الله فيك اخي الحسامي و بارك الله فيك اخي طارق فقط أيضا للإثراء حل اخر بالمعادلات بامكانه استعمال الاسم kh_list كقائمة والذي يحوي على المعادلة =IF(ورقة1!$L$3="";INDEX(قائمة_الفروع;0;2);OFFSET(ورقة1!$E$2;MATCH(ورقة1!$L$3;INDEX(قائمة_الفروع;0;1);0);;COUNTIF(INDEX(قائمة_الفروع;0;1);ورقة1!$L$3))) خبور خير قائمة منسدلة مرتبطة بقائمة أخرى بالمعادلات.rar

السلام عليكم ليس بعد كلام الأساتذة خبور خير والحسامي أي كلام فقط أيضا للإثراء مرفق حل بدون أكواد بإستخدام الدالة Indirect Book2_Tareq.rar

السلام عليكم اخي خبور بارك الله فيك للإبداعات المتميزة ومن بعد إذنك ولاثراء الموضوع هنا حل أخر بإستخدام الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) Dim i, j, k As Integer If Not Intersect(Target, Range("m3")) Is Nothing Then Range("H3:I20").ClearContents For i = 3 To Cells(Cells.Rows.Count, "a").End(xlUp).Row If Target.Value = Cells(i, "a") Then R = 3 For j = 3 To Cells(Cells.Rows.Count, "d").End(xlUp).Row If Cells(i, "b") = Cells(j, "d") Then For k = 5 To 6 Cells(R, k + 3) = Cells(j, k) Next k R = R + 1 End If Next j End If Next i End If End Sub قائمة منسدلة مرتبطة بقائمة أخرى1.rar

السلام عليكم بمجرد الاختيار في الخلية M3 سيغمل الكود Private Sub Worksheet_Change(ByVal Target As Range) Dim Y As Integer, R As Integer If Target.Address = Range("M3").Address Then Me.Range("H3:I20").ClearContents With Range("قائمة_الفروع") For Y = 1 To .Rows.Count If IsError(Target.Offset(0, -1)) Then GoTo 1 If .Cells(Y, 1).Value = Target.Offset(0, -1).Value Then Cells(R + 3, "H").Value = .Cells(Y, 2).Value Cells(R + 3, "I").Value = .Cells(Y, 3).Value R = R + 1 End If Next End With End If 1: End Sub قائمة منسدلة مرتبطة بقائمة أخرى.rar