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

وعليكم السلام محمد.. الملفات الثنائية لها معرفات نصية في أول سطر من الملف! يمكن الاستفادة من هذه الميزة للتعرف على الملف الأصلي حتى لو غُيرت اللاحقة! افتح الملف بواسطة محرر النصوص التقليدي للحصول على معرف الملف ثم استخدم هذا المعرف في فحص القيمة.. في أكسس الشفرة التالية تفي بالغرض إن شاء الله Sub TestData() On Error Resume Next Dim fn, ft fn = CurrentProject.Path & "\testdata\testdata.msi" Open fn For Input Access Read As #1 Line Input #1, ft Close #1 If ft Like "*Standard ACE DB*" Then Name fn As Replace(fn, ".msi", ".accdb") End If End Sub

مشاركة بالفكرة السابقة ..... للتجربة على ملفك ........ kanory.mdb

فكرة بفكرة يمكن تنفيذها وهي : اولا نحتاج تغيير امتداد ملفك الى ملف امتداد ملف اكسس ثانيا نفحص هذا الملف هل هو ملف اكسس صالح فيعطي رسالة بذلك او معطوب فيعطي رسالة ايضا بذلك . . . . افكر في تنفيذها إن اردت .... جاري العمل على ذلك ..............

تفضل ..... المرحله.accdb

ربما هذا يفيدك .... copy.accdb

مساهمة مع الاساتذه الكرام .... جرب المرفق واعلمنا بالنتيجة الارقام.accdb

استخدم هذا الفانك ولاحظ التغيرات وحاول فهم التعديل ...... Function kanory1() On Error Resume Next Dim RSB As DAO.Recordset Dim RSD As DAO.Recordset Dim RSJ As DAO.Recordset Set RSB = CurrentDb.OpenRecordset("tblTempS", 2) Set RSD = CurrentDb.OpenRecordset("tblTempe", 2) Set RSJ = CurrentDb.OpenRecordset("tblTempS", 2) Dim I As Integer ', ClassDay As String, BM RSB.MoveLast RSB.Edit RSB!F24 = "الجهة" RSB.Update RSB.MoveFirst '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Do Until RSB.EOF see: If RSB!F24 Like "*الجهة*" Then g = RSB!f7 ' ElseIf RSB!F20 Like "*الخدمة الرئيسية*" Then ' t = RSB!f5 ' ElseIf RSB!F20 Like "*الخدمة الفرعية*" Then ' s = RSB!f6 End If RSB.MoveNext If RSB!F24 Like "*الجهة*" Then GoTo se Loop '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ se: Do Until RSJ.EOF If IsNumeric(RSJ!F25) Then RSD.AddNew RSD!f3 = RSJ!F2 RSD!f4 = RSJ!F25 RSD!f5 = RSJ!F22 RSD!F6 = RSJ!F18 RSD!f7 = RSJ!F16 RSD!F8 = RSJ!f14 RSD!F9 = RSJ!F13 RSD!F10 = RSJ!F10 RSD!f11 = RSJ!F8 RSD!f12 = RSJ!F6 RSD!f1 = g ' RSD!F2 = t ' RSD!f3 = s RSD.Update End If RSJ.MoveNext If RSJ!F24 Like "*الجهة*" Then g = "" t = "" s = "" GoTo see End If Loop DoCmd.OpenTable "tblTempe" DoCmd.Close acForm, "frmdrjat" End Function

تسلم اخي خالد ....

طيب ... بارك الله فيك اخي الكريم جرب المرفق التالي ..... الباحث فى القرآن الكريم للتعديل.rar

اين تبدو الايه ناقصة ..... عندي ظاهرة كاملة الاية .... وضح طلبك

بالحقيقة عندما ارى هكذا روائع ..يبدوا لي اني كالعصفور امام الصقور الحرة (الشاهين You are awesome Dr.

انظر للمثال المرفق..هل هذا المطلوب؟ Q.accdb

لا أعتقد وجود معادلة تقوم بهذا الدور لذلك يمكنك استعمال اكواد vba مع ملاحظة ان اختيار الاسم في شيت A يجب ان يكون من قائمة الاسماء في شيت B لضمان المطابقة تم وضع معادلات للعد وكود لجلب أيام العياب مجمعة بالتوفيق دمج أيام الغياب في خلية واحدة.xlsb

جرب استعمال هذا الكود Sub masTar7eel() Application.ScreenUpdating = 0 Range("B2:B16").Copy Sheets("الشيت").Select lr = Cells(Rows.Count, 1).End(xlUp).Row + 1 Range("A" & lr).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True Application.CutCopyMode = 0 Range("A" & lr).Select Sheets("ادخال بيانات").Select Range("B2:B16").ClearContents Range("B2").Select Application.ScreenUpdating = 1 MsgBox "Done by mr-mas.com" End Sub وهو عبارة عن تسجيل ماكرو لنسخ الخلايا من الشيت الاول الى آخر صف في الشيت الثاني مع خيار اللصق transpose ولا تنس أن تحفظ الملف بامتداد يدعم الاكواد مثل xlsb بالتوفيق

استخدم هذا المكود و لا تنسى اضافة اسماء الجداول في المتغيير On Error Resume Next If MsgBox("هل تريد افراغ الجداول المحدد ؟", vbExclamation + vbYesNo + vbMsgBoxRight, "تنبيه") = vbYes Then If InputBox("ادخل كلمة المرور لتأكد الحذف", "تأكيد افراغ الجداول") = "123" Then Dim db As DAO.Database Dim tdf As DAO.TableDef Dim NonTB1 As String NonTB1 = "table_name1" NonTB1 = (NonTB1 + ",") & "table_name2" NonTB1 = (NonTB1 + ",") & "table_name3" Set db = CurrentDb For Each tdf In db.TableDefs If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*" Or tdf.Name Like "exl*") Then If tdf.Name <> Split(NonTB1, ",")(0) And tdf.Name <> Split(NonTB1, ",")(1) And tdf.Name <> Split(NonTB1, ",")(2) Then sSQL = "DELETE FROM " & tdf.Name db.Execute sSQL End If End If Next MsgBox "تم افراغ الجداول المحددة بنجاح", vbMsgBoxRight + vbInformation, "تأكيد" End If End If

يمكنك استعمال هذا الإجراء وربطه بشكل أو زر في شيت سجل قيد بيانات Sub mas_getdata() Dim sh As Worksheet, n As Long, lr As Long, lr2 As Long Set sh = Sheets("data") lr = sh.Cells(Rows.Count, 2).End(xlUp).Row Application.ScreenUpdating = 0 Range("b17:s218").ClearContents For n = 9 To lr If sh.Range("f" & n) = [e2] And sh.Range("g" & n) = [e3] Then lr2 = Cells(Rows.Count, 2).End(xlUp).Row + 1 lr2 = IIf(lr2 < 17, 17, lr2) For c = 2 To 19 Cells(lr2, c) = sh.Cells(n, Cells(1, c)) Next c End If Next n Application.ScreenUpdating = 1 MsgBox "Done by mr-mas.com" End Sub ملحوظة: تم استخدام الأرقام في الصف الأول في الكود فلا يجب مسحها يمكن إخفاء الصف بالتوفيق

تفضل هذا التعديل شامل لكل ما طلبت سوف تتمكن من اختيار الجداول التي ترغب في افراغ البيانات منها الرقم السري داخل الكود لإفراغ البيانات 123 T2t2.accdb

وعليكم السلام ورحمة الله وللاكاته افضل اخي الكريم If DCount("[invoice]", "[Table1]", "[invoice] =" & Me.qty) > 0 Then MsgBox "رقم الفاتورة مكرر" End If تحياتي

وهذا برنامج ايضا للبحث ويقوم بعرض عدد مرات تكرار الكلمة في القران وايضا لو ضغط دبل كللك على الايه ينسخها لك بشكل تقرير ويمكن نسخ الاية للحافظة لنقلها للوورد مثلا للأمانه البرنامج منقـــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــول Holy_Quran.rar

الملف ليس فيه مشكلة انظر ..... ولكن انسب البرنامج لصاحبة تعود الايات بالظهور .... مع تحياتي للاستاذ محمد صالح @أ / محمد صالح

If MsgBox(" هل تريد حفظ السجل ؟ ", vbYesNo, " تنبيه ") -= vbNo Then Cancel = True SendKeys "{ESC}" Exit Sub End If

تفضل ... zaBarCode_Items.mdb

ايضا مشاركة مع اخي الاستاذ @محمد أبوعبدالله تفضل ... Public Function CountChar() As Integer Dim StringToSearch As String, Character As String StringToSearch = Me.txtTest CountChar = 0 For i = 1 To Len(StringToSearch) ms = Mid(StringToSearch, i, 1) Strr = Nz(DLookup("n", "Tbl1", "[l] = '" & ms & "'")) Strr2 = Strr2 + Strr Me.kan = Strr2 Next i End Function تم استدعاء الكود ... Call CountChar kan_1238.mdb

جرب هذا الكود ... ضعه بعد امر الطباعة .... ملاحظة لم اجرب الكود Reports("فاتورة").Printer.PaperSize = acPRPSB5 acPRPSB5 يمثل ورق B5 و acPRPSA4 يمثل ورق A4 جرب واعلمنا بالتجربة ...

مرفق ملف لشركة تقدم حوالي 5-10 منتجات وفيها فروع حوالي 10-50 فرع ، وكل فرع به 10-20 موظف ولهم اهداف لابد من تحقيقها شهرية ،، ومرفق امثلة بسيطة اريد افضل عروض بالرسومات البيانية لكل فرع ، موضح به كل موظف ماذا قام في تحقيق اهدافه بشكل جميل وملفت كيف اقوم بذلك بارك الله فيكم اريد من يدلني على الطريق والشرح 111.xlsx

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

مصر ام الدنيا في الثقافة والعلم .. فاول مكتبة عملاقة في التاريخ هي مكتبة الاسكندرية تستطيع ان تكون خبيرا بالاجتهاد والمثابرة وانا ارى فيك تلك الروح المثابرة .. لكن نصيحتى لا تتعود على النسخ واللصق .. اي كود يمر عليك ادرسه بشكل جيد واسأل عن اي شي لم تفهمه فليس عيبا ان تسال .. لكن العيب ان يبقى الانسان جاهلا (حاشاك طبعا) بالتوفيق يارب

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

حبيبي استاذ قاسم الله يساعدك وجل من لا يخطا

السلام عليكم كود جميل استاذ قاسم لكن ملاحظة ارجو تقبلها في الشرط الثالث If M = 1 Or M <= 10 Then m=1 ليسلهاداعي لان الجزء الثاني من الشرط يحقق m=1 والافضل كتابتها كالاتي If M <= 10 Then كذلك طلب الاخ هي الارقام المحصورة بين 1و10 لذا تكتب كالاتي If M >= 1 and M <= 10 Then وعذرا للاطالة

If M = 1 Or M <= 10 Then لو القيمة مش بتساوى اى ارقام من 1 الى 10 تظل النتيجه كما هى

ما شاء الله رووووعة

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

تدري انه جاهز و في بداية البرنامج سويته و انت اعترضت عليه فأزلت الارتباط له من الصفحة الرئيسية و الآن بعد مرور هذي المدة طلعت تحتاجه

شكرا أستاذي الفاضل .. بإذن الله ان واجهتني مشكلة سوف أرجع لك

ربما يكون هذا هو المطلوب .. تم إضافة تاريخ السداد المبكر في الخلية L15 تعديل معادلة العمود B & C تعديل معادلة الأشهر المسددة .. بالتوفيق ‫المثال ء _2.xlsm

وعليكم السلام ورحمة الله وبركاته لمعرفة امتداد الملف استخدم الكود التالي Dim File_Type As String Dim DB_Full_Name As String DB_Full_Name = CurrentProject.Path & "\" & CurrentProject.Name File_Type = Mid(DB_Full_Name, InStrRev(DB_Full_Name, ".") + 1) Debug.Print File_Type ولمعرفة مسار الملف استخدم الكود التالي Debug.Print CurrentProject.Path ولمعرفة اسم قاعدة البيانات CurrentProject.Name ولمعرفة اسم قاعدة البيانات مع المسار كاملا استخدم الكود التالي Debug.Print CurrentProject.Path & "\" & CurrentProject.Name تحياتي

امين يارب ... واياكم

اكيد في برنامجه الاساسي جدول يتم تصدير وحفظ كل فاتورة بعد الانتهاء منها وتصفير النموذج استعدادا لفاتورة جديدة ....

ضع في حدث عند التغيير هذا الكود .... Me.TextBox1.SetFocus

انت في منتدى كله خبراء وانا تلميذ لديهم انظر هل هذا جزء من اكوادك ..... Private Sub btnActivate_Click() Solved = CLng(Me.txtNum) If IsNumeric(Me.txtKey) = True Then If CLng(Nz(Me.txtKey, 0)) = 123456789 Then If Len(Me.txtCode) = 9 Then If Left(Me.txtCode, 1) = "i" Or Left(Me.txtCode, 1) = "c" Then If Right(Me.txtCode, 1) = "x" Or Right(Me.txtCode, 1) = "o" Then If IsNumeric(Mid(txtCode, 5, 1)) = True Then If IsNumeric(Mid(Me.txtCode, 3, 1)) = True Then If IsNumeric(Mid(Me.txtCode, 7, 1)) = True Then mNum = (Val(Mid(Me.txtCode, 3, 1)) + Val(Mid(txtCode, 5, 1)) + Val(Mid(Me.txtCode, 7, 1))) - 1 DLOldKey = Nz(DLookup("[OldKey]", "tblSetting"), 0) If Me.txtCode <> DLOldKey Then DoCmd.SetWarnings False DoCmd.RunSQL "Update tblSetting Set tblSetting.BaseDate=#" & Format(Date, "yyyy/mm/dd") & "#" DoCmd.RunSQL "Update tblSetting Set tblSetting.ActiveDate=#" & Format(DateAdd("m", mNum, Date), "yyyy/mm/dd") & "#" DoCmd.RunSQL "Update tblSetting Set tblSetting.OldKey='" & Me.txtCode & "'" DoCmd.SetWarnings True MB = MsgBox("Êã ÊÝÚíá ÇáäÙÇã ÈäÌÇÍ" & vbNewLine & "ÓÇÑí ÍÊì: " & DateAdd("m", mNum, Date), vbInformation, "Êã ÇáÊÝÚíá!") DoCmd.Close DoCmd.OpenForm "frmMainLogin" Else Me.txtCode = "" MB = MsgBox("ßæÏ ÊÝÚíá ãäÊåí ÇáÕáÇÍíÉ¡ ÈÑÌÇÁ ÇáÊæÇÕá ãÚ ÇáãØæÑ" & vbNewLine & vbNewLine & "01018877763 - 01201456588", vbCritical, "ÝÔá ÇáÊÝÚíá!") Me.txtCode.SetFocus End If Else Me.txtCode = "" MB = MsgBox("ßæÏ ÊÝÚíá ÛíÑ ÕÍíÍ¡ ÈÑÌÇÁ ÇáÊæÇÕá ãÚ ÇáãØæÑ" & vbNewLine & vbNewLine & "01018877763 - 01201456588", vbCritical, "ÝÔá ÇáÊÝÚíá!") Me.txtCode.SetFocus End If Else Me.txtCode = "" MB = MsgBox("ßæÏ ÊÝÚíá ÛíÑ ÕÍíÍ¡ ÈÑÌÇÁ ÇáÊæÇÕá ãÚ ÇáãØæÑ" & vbNewLine & vbNewLine & "01018877763 - 01201456588", vbCritical, "ÝÔá ÇáÊÝÚíá!") Me.txtCode.SetFocus End If Else Me.txtCode = "" MB = MsgBox("ßæÏ ÊÝÚíá ÛíÑ ÕÍíÍ¡ ÈÑÌÇÁ ÇáÊæÇÕá ãÚ ÇáãØæÑ" & vbNewLine & vbNewLine & "01018877763 - 01201456588", vbCritical, "ÝÔá ÇáÊÝÚíá!") Me.txtCode.SetFocus End If Else Me.txtCode = "" MB = MsgBox("ßæÏ ÊÝÚíá ÛíÑ ÕÍíÍ¡ ÈÑÌÇÁ ÇáÊæÇÕá ãÚ ÇáãØæÑ" & vbNewLine & vbNewLine & "01018877763 - 01201456588", vbCritical, "ÝÔá ÇáÊÝÚíá!") Me.txtCode.SetFocus End If Else Me.txtCode = "" MB = MsgBox("ßæÏ ÊÝÚíá ÛíÑ ÕÍíÍ¡ ÈÑÌÇÁ ÇáÊæÇÕá ãÚ ÇáãØæÑ" & vbNewLine & vbNewLine & "01018877763 - 01201456588", vbCritical, "ÝÔá ÇáÊÝÚíá!") Me.txtCode.SetFocus End If ElseIf Me.txtCode = "ÊÓÊ íÇ Úã" Then Me.txtCode = "" MB = MsgBox("Êã ÊÝÚíá ÇáäÙÇã ãÄÞÊÇ", vbInformation, "Êã ÇáÊÝÚíá!") DoCmd.Close DoCmd.OpenForm "frmMainLogin" Else Me.txtCode = "" MB = MsgBox("ßæÏ ÊÝÚíá ÛíÑ ÕÍíÍ¡ ÈÑÌÇÁ ÇáÊæÇÕá ãÚ ÇáãØæÑ" & vbNewLine & vbNewLine & "01018877763 - 01201456588", vbCritical, "ÝÔá ÇáÊÝÚíá!") Me.txtCode.SetFocus End If Else Me.txtKey = "" MB = MsgBox("ãÝÊÇÍ ÇáÊÝÚíá ÛíÑ ÕÍíÍ¡ ÈÑÌÇÁ ÇáÊæÇÕá ãÚ ÇáãØæÑ" & vbNewLine & vbNewLine & "01018877763 - 01201456588", vbCritical, "ÝÔá ÇáÊÝÚíá!") Me.txtKey.SetFocus End If Else Me.txtKey = "" MB = MsgBox("ãÝÊÇÍ ÇáÊÝÚíá ÛíÑ ÕÍíÍ¡ ÈÑÌÇÁ ÇáÊæÇÕá ãÚ ÇáãØæÑ" & vbNewLine & vbNewLine & "01018877763 - 01201456588", vbCritical, "ÝÔá ÇáÊÝÚíá!") Me.txtKey.SetFocus End If End Sub

مشكلة عدم جمع الوقت سببها اختلاف القيمة في الخلية عن قيمة الوقت لذلك يجب إولا إصلاح قيمة الخلية بهذا الاجراء Sub mas() For n = 2 To Cells(Rows.Count, 4).End(xlUp).Row Cells(n, 4).Value = Cells(n, 4).Text Next n End Sub ستجد بعدها خلية المجموع تعمل وللحصول على الإجمالي بالدقائق يمكنك تغيير تنسيق الخلية I2 إلى عام وكتابة المعادلة التالية =INT(SUM(D2:D233)*24*60) بالتوفيق

لمنع تعديل الصور في نافذة حماية الشيت protect sheet قم بإلغاء تنشيط edit objects

يمكنك استخدام هذه المعادلة =INDEX($B$2:$E$5,MATCH($J3,$A$2:$A$5,0),COUNTA(B2:E2)) البحث عن اخر قيمة فى الصف.xlsm

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

اليوم وبمناسبة أول يوم في شهر رمضان المبارك يسعدني أن أقدم لكم هذه المعلومة السريعة لعمل اختصار لبرنامجك بأيقونة مختلفة عن أيقونة الإكسل الافتراضية ويفتح بدون عرض الشاشة الافتتاحية للإكسل طريقة العمل نضغط كلك يمين في أي مكان خالي ونختار new ثم shortcut سيظهر هذا الحوار نكتب ما يلي "C:\Program Files\Microsoft Office\Office12\EXCEL.EXE" /e "c:\myfolder\myfile.xlsx" مع التركيز على علامات التنصيص ثم نضغط next ثم نكتب اسم الاختصار ثم نضغط finish سيظهر لنا الملف نضغط عليه كلك يمين ونختار propreties ستظهر هذه النافذة التي تمكننا من تغيير التعليق الذي يظهر على الملف عند مرور الماوس عليه وتغيير حجم نافذة البرنامج maxmize وتغيير ايقونته كما بالصورة وعند الضغط على change icon تظهر نافذة صغيرة بها أيقونات من الإكسل نضغط على browse لاستعراض الأيقونة من الجهاز ثم نضغط ok ثلاث مرات لتأكيد الاختيارات وفي النهاية ستجد الاختصار بهذا الشكل يمكنك استخدام هذا الاختصار في البرامج التي تقوم بتحزيم برنامجك وعمل برنامج تثبيت له ونسخها في مسار سطح مكتب العميل تحياتي للجميع أخوكم محمد صالح لا تنسوني من صالح دعائكم وخاصة في هذه الأيام المباركة

انت اللي أستاذ يا أبو عمار أسعدني مرورك كل عام وجميع الإخوة والأخوات بخير

بالفعل أخي ابن سينا هذه الخاصية تسمى auto preview المعاينة التلقائية ويمكن تفعيلها أو إلغائها من خصائص الإكسل excel options

كثيرا ما نحتاج لتلوين الصفوف لتسهيل متابعة معلومات الصف خاصة في حالة كثرة الأعمدة واليوم أحضرت لكم نصيحة سريعة تستعمل في هذا الغرض تلوين الصفوف بالتتابع صف بخلفية بيضاء وصف بخلفية رمادي لعمل ذلك اتبع الآتي حدد جميع خلايا الشيت من التبويب home الصفحة الرئيسية اضغط على conditional formating التنسيق الشرطي كما بالصورة ثم اختر new role قاعدة جديد كما بالصورة ستظهر نافذة القاعدة الجديدة اختر الاختيار الأخير ثم اكتب المعادلة الآتية =iseven(row()) وتعني أن يكون الصف عددا زوجيا مكان المعادلة التي في الصورة ثم اضغط على تنسيق format تظهر لك النافذة التالية اختر منها التبويب fill تعبئة واختر اللون المناسب ثم اضغط موافق كما بالصورة السابقة ثم اضغط موافق على النافذة الأولى ستجد الشيت بهذا المظهر الذي لا تتعب العين في متابعة صفوفه تحياتي للجميع

هل تعلم أن نسخ المعادلات في إكسل 2003 كان بهذا الكود Selection.AutoFill Destination:=Range("c4:c20"), Type:=xlFillDefault وكان يستهلك من ذاكرة الجهاز قدرا كبيرا أما في إكسل 2007 جرب هذا الكود Selection.FillDown وذلك طبعا بعد تحديد الخلية في الحالتين Range("c4:c20").Select ويمكنك ايضا استعمال fillright fillleft fillup تحياتي للجميع