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

جرب هذا الماكرو Sub Fil_combo() Dim k, col, arr(), i%: i = 1 For k = 1 To Sheets.Count col = Sheets(k).Tab.Color If col Then ReDim Preserve arr(1 To i) arr(i) = Sheets(k).Name i = i + 1 End If Next With Me.ComboBox1 .List = Split(Join(arr, ","), ",") .Value = .List(0) End With End Sub COMBO_fil.xlsm

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

السلام عليكم تم عمل المطلوب بمعادلة صفيف... في الملف المرفق. test - Copy.xlsx

الغالبية هناتعمل على اصدار اوفيس 2007 و 2010 قم بعمل نسخه بصيغة 2007 أو 2010 ليتم النظر بطلبك وبعد ذلك يمكنك تطبيق الحل على نسختك ::بالتوفيق::

السلام عليكم توجد العديد من البرامج الخاصة باسترجاع الملفات المحذوفة من الحاسوب منها (Recuva- Recovery My File) تحياتي

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

ممكن عملها اذا كان رقم 2020 ثابت لا يتغير في حدث بعد التحديث للحقل m p r نضع الكود التالي [Person_in_charge] = [Person_in_charge] & "/2020" اما اذان 2020 يرمز للعام فالافضل انشاء حقل مخفي في النموذج تكون قيمته =Year(Date()) والهدف من ذلك ان سجلات العام القادم تاخذ الملحق /2021 وهكذا للسنوات القادم ويكون الكود على النحو التالي [Person_in_charge] = [Person_in_charge] & "/" & [y_d] y_d اسم الحقل المخفي الخاصة العام يمكن الاستغناء عن الحقل المخفي عن طريق متغيير ولكن دائما الحل الاسهل اسرع في وصول المعلومة للمتلقي المثال مرفق PRODUCT21.mdb

تم العمل كما تريد الكود يلون الصفوف الغريبة اوتو ماتيكياً Option Explicit Sub test() Dim RgA As Range, RgC As Range Dim Find_rg As Range, Rgl As Range Dim Dic_Yes As Object Dim m%, x%, R%, arr Set RgA = Sheets(1).Range("A4", Range("A3").End(4)) Set RgC = Sheets(1).Range("C4", Range("C3").End(4)) '=========================== Set Rgl = Sheets(1).Range("L4").CurrentRegion R = Rgl.Rows.Count If R > 1 Then Rgl.Offset(1).Resize(R - 1).Clear End If '============================ Set Dic_Yes = CreateObject("Scripting.Dictionary") For x = 1 To RgA.Rows.Count Set Find_rg = RgC.Find(RgA.Cells(x), lookat:=1) If Not Find_rg Is Nothing Then R = Find_rg.Row arr = Sheets(1).Cells(R, 3).Resize(, 8).Value arr = Application.Transpose(Application.Transpose(arr)) Dic_Yes.Add m, Join(arr, "*") m = m + 1 End If Next For x = 0 To Dic_Yes.Count - 1 Range("L" & x + 4).Resize(, 8).Value = Split(Dic_Yes.Item(x), "*") Next x = x + 4 For m = 1 To RgC.Rows.Count If IsError(Application.Match(RgC.Cells(m), RgA, 0)) Then RgC.Cells(m).Resize(, 8).Copy Cells(x, "L") Cells(x, "L").Resize(, 8).Interior.Color = RGB(0, 204, 255) x = x + 1 End If Next With Range("l4").Resize(x - 4, 8) .Value = .Value .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 End With Set RgA = Nothing: Set RgC = Nothing Set Find_rg = Nothing: Set Rgl = Nothing Set Dic_Yes = Nothing: Erase arr End Sub Farz1.xlsm

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

استعراض نتائج كل شهر من هذة السنوات باستخدام القائمة المنسدلة

ممكن هذا الشيء ان يكون المطلوب my_sum.xlsx

وعليكم السلام ارجو ان يكون هذا المطلوب الطلبيات.rar

السلام عليكم الأخوات الكريمات، الإخوة الكرام هذا المورد الرقمي يشغل على الحاسب بعد فك الضغط عنه وهو مورد رقمي بالأوتوبلاي كان ثمرة دورة تكوينية حول برنامج الأتوبلاي كان لي شرف الإشراف عليها وقد مزجنا في هذا البرنامج بين تقنيات الأتوبلاي و استغلال تقنيات الإكسيل في ميداننا التعليمي خاصة الشق المتعلق باستثمار النقط المورد تفاعلي عبر الترحيب باسم المستخدم وتوديعه وشكره باسمه في نافذة الترحيب يظهر الوقت والتاريخ الحالي المورد يوفر السؤال/ المهمة ووثيقة الإشتغال و الجواب للمقارنة بما أنجزه المستخدم لتتحقق الإفادة بالاضافة لمعادلات إكسيل وشرحها وكتاب رائع حول تعلم VBa بالعربية البرنامج عربي إن ظهرت لكم النوافذ بحروف غريبة ساتفاعل معكم لحل المشكلة التي سببها أن حاسوبكم لايدعم البرامج العربية أتقاسم معكم موردي الرقمي ومورد أحد الإخوة المتوفقين في إنجاز هذا المورد ولا نسألكم إلا الدعاء الصالح بظهر الغيب لي وللأخ عبد الالاه: التحميل من هنا: مورد هشام: https://drive.google.com/file/d/13JZ...ew?usp=sharing مورد عبد الالاه: https://drive.google.com/open?id=1mI...DbKroZoMJcpbey والله ولي التوفيق

وعليكم السلام ولماذا لا تراجع شركة يمن سوفت لحل هذة المشكلة لان البرنامج من حقوقهم ولا يسمح بالتعديل عليه

وفق الله الجميع لما يحب ويرضى تحياتي لكم جميعا

كل الشكر للاخ ابو بسمله وكذلك الشكر موصول للاخ صلاح

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

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

تعديل بسيط على كود الاخ صلاح جزاه الله خيرا بملاحظه الاخ السائل لعمل تحديث للنموذج الفرعى بعد الادخال عند عدم الادخال والضغط عالزر سوف تظهر لك الرساله عند الادخال والضغط عالزر سيتم الانتقال لسجل جديد جزاه الله خيرا الاخ @صلاح جبر Private Sub Command24_Click() Me.Child12.Form.Requery If Me.tob = 0 Then MsgBox "ادخل رقم السائق", vbCritical, "صلاح جبر" Me.Child12.SetFocus Else DoCmd.GoToRecord , , acNewRec End If End Sub تقبلوا تحياتى وتمنياتى لكم وللجميع بالتوفيق

لن تستطسع فتح الملف باصدار 2010 قم بفتح الملف عن طريق اصدار 2016 بعد ذلك قم بعمل نسخه عن طريق حفظ باسم واختر الاصدار من القائمة التي ستظهر لك ::بالتوفيق::

أتمنى لكم التوفيق أخي العزيز. وأعتذر لعدم تمكني من مساعدتكم.

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

ممتاز اخي صلاح هذا المطلوب ....لاكن كيف الطريقه هل ماكرو ام كود حسب ما رايت انك عملت حساب لعدد السجلات الموجودين في النموذج الفرعي فاذا كانت القيمه صفر تجي الرساله واذا كانت معبئه فالامور في السليم ولاكن اين وضعت هذا الكود If Me.tob = 0 Then MsgBox "ÇÏÎá ÑÞã ÇáÓÇÆÞ", vbCritical, "ÕáÇÍ ÌÈÑ" Me.Child12.SetFocus Else DoCmd.GoToRecord , , acNewRec End If لم اري حدثا في خصائص الحقول او النماذج جزيت خيرا

تحت امرك اخي Cells.Columns.AutoFit

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

أستاذ abdh4747 أين الضغط على الإعجاب على هذه الإجابات الممتازة وهذا اقل ما يقدم لصاحب الفضل بعد ربنا فى حل مشكلتك ؟! 💙

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

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

السلام عليكم بعد اذن اخي محمد هذه قكرةرائعىة انه يخصص الشخض قاعدة بيانات فارعة وليس سيرفر لارشفة الجداول المهمة في جميع قواعد البيانات لنفرض فاعدةالبيانات المراد ترحيل الجدولayman1 والقاعدة الفارغة archieve Dim db As DAO.Database Dim blnTrans As Boolean Dim strSQL As String Dim strPath As String Dim strDb As String Dim strDateCriteria As String ' On Error GoTo ErrorHandler strPath = "C:\AYMAN71\" strDb = "ayman1.accdb" strDateCriteria = _ "BETWEEN #1/1/2000# AND #12/31/2022#;" DBEngine.BeginTrans blnTrans = True Set db = OpenDatabase(strPath & strDb) ' نسخ جدول orders ' وتصديره ثم حذفه strSQL = _ "SELECT * INTO origin IN " & _ Chr(34) & strPath & strDb & Chr(34) & _ " FROM Orders WHERE Orders.OrderDate " & _ strDateCriteria db.Execute strSQL, dbFailOnError ' تاكبد If MsgBox("Click OK if you want to archive " _ & db.RecordsAffected & _ " records.", vbOKCancel + _ vbQuestion + vbDefaultButton2, _ "Proceed?") = vbOK Then DBEngine.CommitTrans DoCmd.TransferDatabase acImport, "Microsoft Access", "C:\ayman71\ayman1.accdb", acTable, "origin", "archive" db.TableDefs.Delete ("origin") Application.RefreshDatabaseWindow Else If blnTrans Then DBEngine.Rollback End If If db.RecordsAffected = 0 Then DBEngine.Rollback MsgBox "لا حركات " & _ "with the specified criteria.", _ vbInformation + vbOKOnly, _ "Records not found" End If Cleanup: Set db = Nothing Exit Sub

اضافة أمر حفظ سجل قبل تشغيل SQL DoCmd.RunCommand acCmdSaveRecord لازم اضافة هذا امر Edit123.accdb

كان من المفروض ان تذكر المشاركة الثّانية رأساُ لعدم اهدار الوقت باشياء غير مدروسة الكود Option Explicit Sub test() Dim RgA As Range, RgC As Range Dim Find_rg As Range, Rgl As Range Dim Dic_Yes As Object Dim m%, x%, R%, arr Set RgA = Sheets(1).Range("A4", Range("A3").End(4)) Set RgC = Sheets(1).Range("C4", Range("C3").End(4)) '=========================== Set Rgl = Sheets(1).Range("L4").CurrentRegion R = Rgl.Rows.Count If R > 1 Then Rgl.Offset(1).Resize(R - 1).Clear End If '============================ Set Dic_Yes = CreateObject("Scripting.Dictionary") For x = 1 To RgA.Rows.Count Set Find_rg = RgC.Find(RgA.Cells(x), lookat:=1) If Not Find_rg Is Nothing Then R = Find_rg.Row arr = Sheets(1).Cells(R, 3).Resize(, 8).Value arr = Application.Transpose(Application.Transpose(arr)) Dic_Yes.Add m, Join(arr, "*") m = m + 1 End If Next For x = 0 To Dic_Yes.Count - 1 Range("L" & x + 4).Resize(, 8).Value = Split(Dic_Yes.Item(x), "*") Next x = x + 4 For m = 1 To RgC.Rows.Count If RgC.Cells(m).Interior.ColorIndex > 0 Then RgC.Cells(m).Resize(, 8).Copy Cells(x, "L") x = x + 1 End If Next With Range("l4").Resize(x - 4, 8) .Value = .Value .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 End With Set RgA = Nothing: Set RgC = Nothing Set Find_rg = Nothing: Set Rgl = Nothing Set Dic_Yes = Nothing: Erase arr End Sub الملف Farz.xlsm

وعليكم السلام-تفضل تعديل على قاعدة بيانات وحذف البيانات القديمة منها كود لحذف محتويات مجلد

بعد اذن الاخ علي جرب هذا الكود Option Explicit Sub Salim() Dim My_rg1 As Range, RO%, m%, n%, x% Dim Arr1, Ful_arr(), Arr2() Set My_rg1 = Range(Sheets(1).Range("A4"), Sheets(1).Range("A4").End(4)) Arr1 = Application.Transpose(My_rg1) RO = Sheets(2).Cells(Rows.Count, 1).End(3).Row Sheets(2).Range("C4").CurrentRegion.Clear m = 1: n = 1 For x = 4 To RO If IsError(Application.Match(Sheets(2).Range("A" & x), Arr1, 0)) Then ReDim Preserve Arr2(1 To m) Arr2(m) = Sheets(2).Range("A" & x).Value m = m + 1 Else ReDim Preserve Ful_arr(1 To n) Ful_arr(n) = Sheets(2).Range("A" & x).Value n = n + 1 End If Next With Sheets(2).Range("C4").Resize(n - 1) .Value = Application.Transpose(Ful_arr) .Borders.LineStyle = 1 .Interior.ColorIndex = 20 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 If m <> 1 Then With .Offset(n - 1).Resize(m - 1) .Value = Application.Transpose(Arr2) .Borders.LineStyle = 1 .Interior.ColorIndex = 19 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 End With End If End With Erase Arr1: Erase Ful_arr(): Erase Arr2() End Sub الملف مرفق Tartib.xlsm

تفضل محاولة استيراد.rar

وعليكم السلام - تفضل الم تطلع على الملف تم تنفيذ المطلوب بهذا الكود Sub arrange() Sheet1.Activate Columns("A:A").Select Selection.Copy Sheet2.Activate Columns("b:b").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End Sub ترتيب بيانات الصفوف حسب القائمة الأساسية.xlsm

أستاذ sabry fahmy أين الضغط على الإعجاب ؟!💙

عليك السلام ورحمة الله وبركاته بعد إذن الأستاذ khalf كان لزامًا عليك استخدام خاصية البحث في المنتدى

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

خطأ بسيط في التنيسق ( Add_Borders ) تم علاجة المرفقات Test_3.xls

تفضل اخي Test_2.xlsm

الحمدلله لا تنسي تغير هذا السطر في موديول SetUp Public Const Ext = "*.xls" الي Public Const Ext = "*.xlsx" مع اطيب تمنياتي بالتوفيق شاهد المرفقات Test_1.rar

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

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

السلام عليكم تفضل المعادلة الموجودة بالخلية B11 بعد إضافة معادلة مساعدة في العمود G =IFERROR(VLOOKUP(1,D7:G18,4,0),"ادخل رقم حساب الصنف بالخليةc3") if طويلة.xlsm

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

بإمكان المبرمج إغلاق النموذج المفتوح بناء على فترة زمنية لم يستخدم فيها المستخدم الحاسوب سواء الفأرة (Mouse) أو لوحة المفاتيح (Keyboard) وذلك بتعريف عدة أحداث كما يلي: 1. حدث عند التحميل OnLoad Private Sub Form_Load() Me.TimerInterval =20 'تعريف الوقت المطلوب قبل الانهاء End Sub حيث أن TimeInterval هو زمن الانتظار قبل الإغلاق بالمللي ثانية 2. حدث عند عداد الوقت FormTimer Private Sub Form_Timer() DoCmd.Quit 'للخروج من النموذج End Sub 3. حدث عند النقر Click وحدث عند الضغط على مفتاح Private Sub Form_Click() Me.TimerInterval = 20 ' إعادة تعريف الوقت End Sub Private Sub Form_KeyPress(KeyAscii As Integer) Me.TimerInterval = 20 ' إعادة تعريف الوقت End Sub

السلام عليكم مرفق مثال أخر يوضح كيفية حماية قاعدة البيانات وذلك بإغلاقها, اذا لم يحرك المستخدم مؤشر الماوس او الكتابة على لوحة المفاتيح خلال فترة زمنية يتم تحديدها مسبقاً واترك لباقي الزملاء التعديل او طرح طرق أخرى مع تحياتي SecureDatabase.zip

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

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

أحببت أن أطلعكم على الاصل وهو أكثر من 600 كود في الفيجول أكواد v.6.rar