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

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

بكل بساطة اعكس العملية Dim LastRow As Long LastRow = ThisWorkbook.Sheets("xx").Range("g1").End(xlDown).Row LastRow = LastRow + 1

روعة استاذ @kanory فقد تعرف على ملف الاستاذ صاحب المشاركة واظهر بانه ملف اكسس

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

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

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

كلامك صحيح استاذ حسام ربما اصبح لدي اشتباه بين or و And يستطيع الاخ صاحب المشاركة تعديلها اليك التعديل حسب مقترح استاذ حسام Q.accdb

السلام عليكم كود جميل استاذ قاسم لكن ملاحظة ارجو تقبلها في الشرط الثالث 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

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

وعليكم السلام ورحمة الله وبركاته لمعرفة امتداد الملف استخدم الكود التالي 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

يجب عرض التقرير بهذه الطريقة ثم الطباعة ليعمل الكود على تغيير خصائص الصفحة DoCmd.OpenReport "Labels_Table1", acViewPreview Reports("Labels_Table1").Printer.PaperSize = acPRPSB5

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

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

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

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

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

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

شكرا لكل الإخوة على المرور وأتمنى من الجميع المساهمة بما يعرف من تريكات tricks (نصائح سريعة) لينفع بها إخوانه لا يكفي أن نأخذ بلا عطاء وفقنا الله وإياكم لما فيه الخير

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