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

جرب هذا الكود Option Explicit Private Sub Worksheet_Activate() fil_dat_val End Sub '+++++++++++++++++++++++++++++++++++ Sub fil_dat_val() Application.ScreenUpdating = False Dim I%: I = 6 Dim arr Dim rg As Object Set rg = CreateObject("system.collections.arraylist") With rg Do Until Sheets("sheet1").Range("B" & I) = vbNullString If Not .contains(Sheets("sheet1").Range("A" & I).Value) Then _ .Add Sheets("sheet1").Range("A" & I).Value I = I + 1 Loop .Sort arr = .toarray arr = Join(arr, ",") End With With Sheets("sheet2").Range("H2").Validation .Delete .Add xlValidateList, Formula1:=arr End With End Sub '============================== Sub get_values() Dim rg As Object, I%, m%, kY Dim Sh1 As Worksheet, Sh2 As Worksheet I = 6 Set Sh1 = Sheets("Sheet1"): Set Sh2 = Sheets("Sheet2") Set rg = CreateObject("Scripting.dictionary") Sh2.Range("a6").CurrentRegion.Offset(1).Clear With Sh1 Do Until Not IsNumeric(.Range("a" & I)) If .Range("A" & I) = Sh2.Range("h2") _ And .Range("C" & I) >= Sh2.Range("I2") _ And .Range("C" & I) <= Sh2.Range("J2") Then rg(m) = _ .Range("C" & I).Value & "*" & _ .Range("D" & I).Value & "*" & _ .Range("E" & I).Value m = m + 1 End If I = I + 1 Loop End With If rg.Count = 0 Then GoTo End_Me m = 6 For Each kY In rg.keys Sh2.Cells(m, 1).Resize(, 3) = _ Split(rg(kY), "*"): m = m + 1 Next With Sh2.Range("A6:C" & m - 1) .Value = .Value .InsertIndent 1 .Borders.LineStyle = 1 .Font.Size = 14 End With End_Me: Application.ScreenUpdating = True Set rg = Nothing End Sub Saerch_by_date.xlsm

تفضل يمكنك ذلك بإستخدام هذه المعادلة بالتنسيق الشرطى =AND(COUNTIF($A$2:$A$310,H2)=0,H2<>"") تنسيق شرطى للمختلف.xlsx

السلام عليكم الأفضل تجميع البيانات في ملف واحد ، بل في ورقة واحدة لكن علي كل حال تستطيع إستخدام الدالة ( في لوك اب) مع خاصية المطابقة التامة أي مثل VLOOKUP(X,Range,n,0) أي تجعل الدالة تبحث عن المتغير بالضبط تطابق وإلا ترجع بخطأ وذلك عن طريق المتغير الرابع بالدالة تعطيه قيمة 0 أو False ثم قبل الدالة ، تضيف دالة أخري Iferror والتي تغير نطاق البحث من الملف A إلي B مثلا لو أعطي البحث الأول خطأ تفضل الملف به الدالتين ABC.xlsx

TRY THIS FILE ROW_NYMMBER.xlsx

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

السلام عليكم تغضل اخي الكريم ملفك بعد التعديل اتمنى يكون المطلوب Database4.rar

بعد اذن استاد طارق محمود ولاثراء الموضوع جرب المرفق 1 انسخ المجلد المسمى mydata في :d 2 افتح الملف المسمى main واضغط زر استعلام سيأتي ببيانات حسب الرقم في العمود A ملاحظة تم تغيير اسماء الشيتات ليعمل الكود بكفاءة ارجو ان يكون ما تريد my data.rar

داخل المرفقات شوفها بعد التحميل Password: 123456

Mahmoud Mostafa Mandour أين الضغط على الإعجاب ؟!!💙

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

تستطيع ذلك، تحتاج برنامج Android Studio لكي تقوم بعمل تطبيق لعرض الرقم المتصل عن طريق BroadcastReceiver وبعدها ترسله لواجهة الكومبيوتر هذا حل سريع: https://www.cnet.com/how-to/you-can-now-place-and-receive-android-phone-calls-on-your-windows-pc/

بعد اذن استاذنا الفاضل واخونا الحبيب استاذ سليم جزاه الله عنا خير الجزاء واثراء للموضوع جلب رقم الصف.xlsx

بعد أذن الأخ Ali Mohamed Ali الأخ Saadrafic شاهد المرفق هو يعمل جيدا مع ويندوز 64 والمفروض انه يعمل مع ويندوز 32 لقد قمت بتجربة الكود علي windows 32 bit وهو يعمل جيدا ايضا اذن الكود المرفق سابقا يعمل علي كل من نسختي ال windows سواء كانت 32 bit أو 64 bit Show_Keyboard.xlsm

تفضل هذه المعادلة Option Explicit Option Compare Text Function kh_count_y_m_d(Mydate_Birth As Date, Optional Mydate_Now _ , Optional Y_M_D As String = "Y_M_D", Optional MyCalendar As Boolean) Dim Mydate As Date, KH_Calendar As Integer Dim D_1 As Integer, D_2 As Integer, M_1 As Integer, M_2 As Integer, Y_1 As Integer _ , Y_2 As Integer, D As Integer, M As Integer, Y As Integer If IsDate(Mydate_Now) Then Mydate = Mydate_Now Else Mydate = Date If IsDate(Mydate_Birth) And CDate(Mydate_Birth) <= CDate(Mydate) Then KH_Calendar = Calendar If MyCalendar = True Then Calendar = 1 Else Calendar = 0 D_1 = Day(Mydate): D_2 = Day(Mydate_Birth) M_1 = Month(Mydate): M_2 = Month(Mydate_Birth) Y_1 = Year(Mydate): Y_2 = Year(Mydate_Birth) If D_1 >= D_2 Then D = D_1 - D_2: M = 0 Else D = D_1 + 30 - D_2: M = -1 If M_1 + M >= M_2 Then M = M_1 + M - M_2: Y = 0 Else M = M_1 + M + 12 - M_2: Y = -1 Y = Y_1 + Y - Y_2 If Y_M_D <> "Y" Or Y_M_D <> "M" Or Y_M_D <> "D" Then kh_count_y_m_d = Y & "y-" & M & "m-" & D & "d" If Y_M_D = "Y" Then kh_count_y_m_d = Y If Y_M_D = "M" Then kh_count_y_m_d = M If Y_M_D = "D" Then kh_count_y_m_d = D Calendar = KH_Calendar End If End Function kh_count.xlsm

المرحلة الاولي: اضغط زر ويندوز + r اكتب appwiz.cpl ثم اضعط Enter اختار Intel Optane Pinning Explorer Extensions. ثم اختار Repair المرحلة الثانية اضغط زر ويندوز + X ثم اختار Device Manager ثم اختار Intel® Pinning Shell Extensions ثم اختار Software components ثم Uninstall Device

السلام عليكم ورحمة الله وبركاته اخوانى الكرام بالمنتدى كل عام وانتم بخير وتقبل الله منا ومنكم صالح الاعمال لاحظت انه يوجد اسئلة حول كيفية انشاء شريط ادوات مخصص لاكسيس 2007 و 2010 حيث انه فى الاصدارات السابقة من اكسيس 2003 و 2000 كان يمكنك بواسطة الاكسيس نفسه ان تقوم بهذا الامر اما فى اكسيس 2007 وما فوق فيوجد عدة طرق لكنها لا تاتى بالغرض دائما الطريقة الاولى : هو الذهاب الى File فى حالة 2010 او زر الاوفيس فى حالة 2007 واختيار Options ثم 1- الذهاب الى Customize Ribbon ونختار New Tab ونلاحظ ظهور شريط او تبويب جديد باسم (New Tab (custom وتحته مجموعة Group جديد باسم (New Group (custom وهذا يكون بشكل افتراضى ولتغيير اسم التبويب نحدده ونضغط Rename ونكتب الاسم ولتسمية Group نحددها ونضغط Rename 2- اضافة الازرار نقوم بعد ذلك باضافة الازرار بواشسظة السحب والالقاء Drag Drop ويمكن ان نختار الازرار التى نريدها من القائمة فى الاعلى والتوضيح فى الصورة هذه الطريقة لاضافة اوامر موجودة بالاكسيس اصلا ك النسخ واللصق والمحاذاة باختصار الاوامر الموجودة بشريط الادوات 3- اذا اردنا ان قوم باضافة زر يقوم بعمل شىء مخصص مثلا يقوم بفتح فورم معين اولا نقوم بانشاء الماكرو الخاص بالعملية ونسميه مثلا OpenForm والآن نذهب الى Customize ونختار Macros ثم نضيف الماكرو الذى نريده واخيرا يمكن اظهار او عدم اظهار اى من التبويبات باغاء علامة check بجانبها وهكذا نكون قد انتهينا من الطريقة الاولى وعيوب هذه الطريقة انها تطبق على جميع قواعد البيانات الموجودة عندك وليس على واحدة فقط اذا نقلت قاعدة البيانات الى جهاز آخر لا تعمل الاشرطة لان هذا التخصيص يكون فى الاكسس نفسه ويمكن حل هذه المشكلة بتصدير التخصيص ثم نقله الى الجهاز المطلوب واستيراده

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

هذا هو المطلوب ........... شكرا لك أحمد الفلاحجى

الاجابة في النطاق الاصفر من هذا الملف Spec_Char.xlsx

استاذ عبد الجيد

الان ممتاز سهل الله امورك اخي العزيز

اتفضل اخى على تم اضافه سطر لمعالجه خطأ / لايوجد سجل حالى On Error Resume Next تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق Relation2.accdb

روعة جزاك الله خيرا الجزاء استاذي Ali Mohamed Ali

بارك الله فيك استاذ حسن كود ممتاز-وبعد اذنك أخى الكريم ولإثراء الموضوع , هذا حل أخر بالمعادلات =COUNTIFS($B$4:$B$150,$E5,$C$4:$C$150,F$4) معادلة حساب عدد التوافق في الشرط من خليتين.xls

Option Explicit Sub test() Dim x1, x2, lr1, lr2 Application.ScreenUpdating = False Range("f5:h100").ClearContents lr1 = Range("b" & Rows.Count).End(xlUp).Row lr2 = Range("e" & Rows.Count).End(xlUp).Row For x1 = 4 To lr1 For x2 = 5 To lr2 If Cells(x1, 2) = Cells(x2, 5) Then If Cells(x1, 3) = "A" Then Cells(x2, 6) = Cells(x2, 6) + 1 ElseIf Cells(x1, 3) = "B" Then Cells(x2, 7) = Cells(x2, 7) + 1 ElseIf Cells(x1, 3) = "C" Then Cells(x2, 8) = Cells(x2, 8) + 1 'ElseIf Cells(x1, 3) = "D" Then 'Cells(x2, 9) = Cells(x2, 9) + 1 ' 'ElseIf Cells(x1, 3) = "E" Then 'Cells(x2, 10) = Cells(x2, 10) + 1 ' 'ElseIf Cells(x1, 3) = "G" Then 'Cells(x2, 11) = Cells(x2, 11) + 1 End If End If Next Next Application.ScreenUpdating = True End Sub جرب المرفق كود حلقات تكرارية 01.xls

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

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

ماشاء الله مهندس طارق جزاكم الله خير

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

لو أرفق ملف للتعديل افضل .... هل تريد حفظها في نفس مجلد البرنامج أم في مكان إخر ؟؟؟؟؟؟؟ على كل حال أنظر هذا الكود وقم بتعديل ما يلزم حسب مصدر اسم الملف المطلوب هل هو مربع نص أو حقل في جدول أوووووو DoCmd.OutputTo acOutputReport, "Report1", acFormatPDF, CurrentProject.Path & "\" & [text70] & ".pdf", False هذا الكود يحفظ لك الملف في مجلد البرنامج أي بجوار برنلمج مباشرة

تفضل اخي على حسب ما فهمت منك ارجو ان يكون هذا طلبك برنامج لتنظيم الوقت والمواعيـــــــــــد 11.xlsm

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

السلام عليكم تفضلي أختي الكريمة حل سريع بالجداول المحورية وبعض المعادلات الجدول والمعادلات بالورقة2 وبعض المعادلات بورقة البصمة نفسها ليتعرف النظام عندي علي فورمات التاريخ والوقت تقرير البصمة.xlsx

السلام عليكم تواصل معي أخي الفاضل "وجيه شرف الدين" علي الخاص ليخبرني أن الملف به أخطاء وقد صححتها كما أرجو وأحببت أن أضيف الملف بعد التعديل حتي يستفيد منه كل من عنده نفس المسألة فقد غيرت الكود وأضفت عليه بعض الشروحات داخل الكود ليكون دليل لمن يحب التغيير أو التعديل عليه ضبط-كود-توزيع_2.xlsm

اليكم الدرس العاشر من دروس شرح الاكسيل https://youtu.be/-y-KzHhD44A وملف الشرح من المرفقات الدرس العاشر لشرح الاكسيل.xlsm

أزكى التحيّات وأجملها أرسلها لك بكلّ الودّ والحب شاكرًا لك على كل ما قدمت سائلا الله سبحاته وتعالى ان يجعلها في ميزان حسناتك وان يديم عليك نعمه وفضله انه سميع عليم

االبرنامج رائع وتصميمه جميل استمر في ابداعك ربنا يوفقك

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

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

هذا تعدل بسيط على طريقة الأستاذ @صلاح جبر zxc (1).accdb

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

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

كان هناك مشكلة فى وضعك للكود -عدلته ,وأثناء فتحك للملف يعمل العداد ولكن عندما تريد أن تغلق وتحفظ الملف فهناك يتوقف العداد فما عليك عند اعادة تشغيل الملف الا أن التقوم بالضغط على Alt F8 ثم RUN المصنف1.xlsm

توكل .. جزيت خيرا وأنا أشهد بنباهتك مرفق الدرس الرسومات التفاعلية.rar وهذا ملف هدية إلى الغالين يستخدم معيارين للرسم COMPLETE_Dynamic Chart Using Option Buttons.rar وتقبلوا تحياتي

استكمالا للموضوع كود مميز جاهز_كود دبل كليك لاستدعاء اى فورم ...الخ لاهمية الاستفاده من فورم يتم استدعائه بدبل كليك مرفق كود بحث و اضافة بحساسية الاحرف و عليه اذا كنت تقوم بعمل برنامج او ملف به عدد كبير من ادخال البيانات او عدد لا نهائى من تكويد الحسابات فقم باضافة الكود و الفورم للملف و قل الحمد لله تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة تم ارفاق كود الحل من الفاضل _ أ / عبدالله باقشير _ يقوم البحث فى عمود واحد مع الملفات G_Double click_2020.rar و مشاركة اخرى هامه من الفاضل _ أ / أبوعبد الله _ يقوم البحث فى عدة اعمده مع الملفات بحث عن صنف واختياره بفورم.rar و لا تنسونا من صالح الدعاء

جرب هذا الملف تحدد كل الأوراق (من الورقة 2 حتى اخر ورقة الورقة الرابعة مثلاُ)وتكتب المعادلة دفعة واحدة Write_all_in_One.rar

انظر هذه المشاركة لأخي الحبيب المبدع @الزباري وخذ منها ما تريد https://www.officena.net/ib/applications/core/interface/file/attachment.php?id=118806

السلام عليكم ورحمة الله وبركاته الآن سنقوم بشرح الطريقة الجديدة لاضافة شريط ادوات باستخدام لغة التوصيف XML اولا: نقوم باضافة جدول نظام جديد: ننشئ جدول فى عرض التصميم وتكون حقوله كالآتى Field Name Type Field Size ID AutoNumber Long Integer RibbonName Text 255 RibbonXml Memo ونسميه USysRibbons ونحفظه نلاحظ اختفاء الجدول وذلك لان الجداول التى تبدأ ب USys او يعتبرها الاكسس من جداول النظام نفتح الجدول فى طريقة عرض Data Sheet ونضيف اول Tool Bar نضيف اسم الشريط ثم كود XML وهذا ما سنشرحه فى مشاركة قادمة ان شاء الله

الملف مرة تانية بالمرفقات ودا الكود المتسخدم بالشرح On Error Resume Next If Range("a3") = "" Or Range("b3") = "" Or Range("c3") = "" Then MsgBox "bla bla1", vbDefaultButton1, "bla bla1 " Else azsh = Sheet2.Range("c50000").End(xlUp).Row + 1 Sheet1.Range("A3:C3").Copy Sheet2.Cells(azsh, 1).PasteSpecial Paste:=xlPasteValues MsgBox "bla bla2", vbDefaultButton1, "bla bla2 " Sheet1.Range("A3:C3") = "" End If كود ترحيل البيانات- أوفيسنا.rar

السلام عليكم أخي الحبيب / بوعلام أولا إسمح لي فقد حذفت النسخة الأخري من الموضوع ، حيث انك وضعتها بالخطأ كما يحدث لنا جميعا ثانيا تفضل هذا الكود Sub t_booking() Dim sh As Worksheet Sheets("مواقيت الأساتدة").Activate last_row = [B10000].End(xlUp).Row Set sh = Sheets("حجز مواقيت الأقسام") last_row2 = sh.[D10000].End(xlUp).Row For rr = 8 To last_row If Cells(rr, 2) = "" Then GoTo 10 t_name = Cells(rr, 2) For day_col = 6 To 14 Step 2 For j = 8 To last_row2 If sh.Cells(j, day_col) = t_name Then t_time2 = sh.Cells(j, 4) t_deprt = sh.Cells(8 * Int(j / 8), 2) & " -- " & sh.Cells(j, 5) new_col = day_col / 2 + 2 For i = 0 To 7 t_time = Cells(rr + i, 4) If t_time = t_time2 Then Cells(rr + i, new_col) = t_deprt Next i End If Next j Next day_col 10 Next rr End Sub وهذا المرفق ، إضغط الزر الأزرق "مواقيت الأساتدة" المواقيت.rar