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

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

بكل بساطة اعكس العملية 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 لو القيمة مش بتساوى اى ارقام من 1 الى 10 تظل النتيجه كما هى

شكرا لك سيدي محمد صالح سيدي محمد صالح هل استطيع ان ابعث لك ملف موظفين لمؤسسة من اجل جلب تواريخ الغيابات واعدادها من فضلك ؟

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

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

ويمكن اختصار الكود إلى Sub mas160menu() Dim Ws As Worksheet, Sh As Worksheet Dim I As Long, x As Long, n As Long, Lr As Long, c As Integer Set Ws = Sheets("السجل الكلي"): Set Sh = Sheets("قوائم80") Lr = Ws.Cells(Rows.Count, 4).End(xlUp).Row Application.ScreenUpdating = False Sh.Range("C7:F86,H7:K86").ClearContents For t = 1 To 2 1: x = (t - 1) * 40 + 7 For I = n + 9 To Lr If Ws.Cells(I, 6).Value = Sh.Range("D1").Value And Ws.Cells(I, 7).Value = Sh.Range("E1").Value Then Sh.Cells(x, IIf(c Mod 2, 8, 3)).Value = Ws.Cells(I, 4).Value Sh.Cells(x, IIf(c Mod 2, 9, 4)).Resize(1, 2).Value = Ws.Cells(I, 10).Resize(1, 2).Value Sh.Cells(x, IIf(c Mod 2, 11, 6)).Value = Ws.Cells(I, 13).Value If x = t * 40 + 6 Then n = I - 8: c = c + 1 If c Mod 2 Then GoTo 1 Else GoTo 2 End If: End If x = x + 1: n = I + 1 End If Next I 2: Next t Application.ScreenUpdating = True MsgBox "Done by mr-mas.com" End Sub ويجب إعادة تعيين الماكرو للزر مع الاسم الجديد وهذا ملفك بعد التعديل .. بالتوفيق تعديل كود القوائم.xls

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

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

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

هل هذا ماتريد؟؟؟؟ انظر النموذج ..... كلمة المرور هي نفسها mohd1234 Dawam1 (1)1.accdb

الله يسلمك على رأسي والله انك استفدت شكرا لك

بالاضافة الى ما تفضل به استاذنا الفاضل @د.كاف يار وله جزيل الشكر تفضل اخي الكريم جرب الكود التالي Dim strFolderPath As String Dim DB_Full_Name As String Dim DB_Name As String Dim Backup_Full_Name As String Dim Copy_File As Variant Dim DB_Directory As String strFolderPath = CurrentProject.Path & "\Backup\" ' التاكد من وجود مجلد Backup ' اذ لم يكن موجود يتم انشائه If Len(Dir(strFolderPath, vbDirectory)) = 0 Then MkDir strFolderPath End If ' تحديد قاعدة البيانات DB_Full_Name = CurrentProject.Path & "\" & CurrentProject.Name ' تحديد مسار قاعدة البيانات DB_Directory = CurrentProject.Path ' تحديد اسم قاعدة البيانات DB_Name = CurrentProject.Name ' تحديد مسار النسحة الاحتياطية Backup_Full_Name = strFolderPath & Left(DB_Name, Len(DB_Name) - 6) & Format(Date, "yyyy-mm-dd") & "-" & Format(Now(), "Hh-Nn-Ss-AMPM") & ".accde" If MsgBox("هل تريد اجراء نسخة احتياطية من البرنامج؟", vbQuestion + vbYesNo, "نسخة احتياطية") = vbYes Then Set Copy_File = CreateObject("Scripting.FileSystemObject") Copy_File.copyfile DB_Full_Name, Backup_Full_Name, True End If تحياتي

أما أنا فأحمد الله أنك لم تفعل ذلك! لأن طريقتك أجود في نظري! أتمنى لك التوفيق

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

موعدنا اليوم مع نصيحة جديدة كثيرا ما نحتاج أن نتأكد من حساباتنا باستعمال الآلة الحاسبة الخاصة بالويندوذ وهذه طريقة وضع آلة الويندوز الحاسبة داخل إكسل 2007 أولا يظهر شريط الوصول السريع كما بالصورة في أعلى يسار النافذة ويحتوي على زر حفظ وتراجع وإعادة فقط ويمكننا تخصيصة بالضغط على السهم بزر الفارة الأيسر ثم اختيار أوامر أكثر more commands كما في هذه الصورة ستظهر هذه النافذة نختار من القائمة all commands كل الأوامر ثم نستعرض الأوامر إلى أن نصل إلى caculation الحاسبة ثم نختارها ثم نضغط على زر add ستجد أنها ظهرت في الجانب الأيمن ثم نضغط موافق ok النتيجة كما يلي عندما نضغط على زر الحاسبة الموجود في شريط الوصول السريع تظهر لنا حاسبة الويندوز إلى اللقاء في نصيحة سريعة ومفيدة بإذن الله أخوكم أبو عبد الله محمد صالح

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

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

شكرا لمرورك الكريم كل عام أنتم بخير

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