نجوم المشاركات
Popular Content
Showing content with the highest reputation on 23 يول, 2021 in all areas
-
4 points
-
تفضل هذا الكود فقط انسخ و الصق في ازرار النسخة الاحتياطية On Error GoTo ErrH Dim fso As Object Dim fldrname As String Dim fldrpath As String Set fso = CreateObject("scripting.filesystemobject") fldrpath = CurrentProject.Path & "\Backup" If Not fso.FolderExists(fldrpath) Then fso.createfolder (fldrpath) DoCmd.RunSQL "CREATE TABLE Backup (Backup_NO INT , Backup_Name VARCHAR (50) , Backup_Path VARCHAR (100), Backup_Date Date);" End If Dim MyFile, DstFile, DataName As String Dim Syso As Object MyFile = CurrentProject.FullName DataName= "Backup-" & Format(Now, "dd-mm-yyyy") & "-(" & Format(Now, "hh.nn.ss") & ")" DstFile = CurrentProject.Path & "\Backup\" & DataName & ".accdb" DBEngine.Idle Set Syso = CreateObject("Scripting.FileSystemObject") Syso.copyfile MyFile, DstFile Set Syso = Nothing Name DstFile As DstFile & ".ptc" DBEngine.CompactDatabase DstFile & ".ptc", DstFile Kill DstFile & ".ptc" Dim db As DAO.Database Dim MaxBackup_NO As Integer MaxBackup_NO = Nz(DMax("[Backup_NO]", "[Backup]"), 0) + 1 Dim rs As DAO.Recordset Set db = CurrentDb Set rs = db.OpenRecordset("Backup") With rs .AddNew ![Backup_NO] = MaxBackup_NO ![Backup_Name] = DataName ![Backup_Path] = DstFile ![Backup_Date] = Now() .Update End With rs.Close Set rs = Nothing MsgBox "تم انشاء قاعدة البيانات بنجاح", vbMsgBoxRight + vbOKOnly, "تاكيد" Exit Sub ErrH: Select Case Err.Number End Select3 points
-
2 points
-
إذا كنت تقصد المعادلة في الخلية M18 فهذه تأتي بمعادلة البحث المستعملة في الشيت =VLOOKUP(D3,B26:L61,11,0) لأن خلية حالة العقد في الجدول بالأسفل تعتمد على خلية أخرى هي خلية سداد مبكر بتاريخ بالتوفيق2 points
-
يمكنك استعمال هذه الدالة المعرفة Function checknum(rng As Range) For n = 1 To 100 If Sqr(rng * n + rng.Offset(0, 1)) = rng.Offset(0, 2) Then checknum = rng.Offset(0, 2): Exit Function End If Next n checknum = 0 End Function ولاستدعاء الدالة نضع في الخلية F2 =checknum(A2) ولا تنس حفظ الملف بصيغة تدعم الماكرو مثل xlsb بالتوفيق2 points
-
2 points
-
اجعل القيمة الافتراضية لرقم القيد =DLast("[رقم_القيد]";"السيارات")+1 عذرا استاذ عبد اللطيف ..ظننتك تريد اخر سجل وليس اكبر سجل2 points
-
السلام عليكم اهل المنتدى الكرام أقدم اليكم برنامج : لجميع الانشطة ( تجارى – صناعى – خدمى – مقاولات ) مطابق تمام لمعايير المحاسبة الدولية كافة المعاملات ( حسابات ختامية – مراقبة مخازن – عملاء – موردين – شئون عاملين – استيراد – تصدير – مستخلصات – مراكز تكلفة – خطوط انتاج – مقايسات - باركود) يشمل البرنامج :- - حسابات الاستاذ كاملة وموازين المراجعة والارباح والخسائر والمركز المالى - تكاليف العمليات وتحليل تكاليف المشروعات وبنود الاعمال بشكل تفصيلى واجمالى - مستخلصات المشروعات - الايرادات - ومستخلصات مقاولين الباطن - منظومة الاجور والمرتبات بشكل متكامل ويمكن تعديلها حسب قانون الدولة - حسابات ضريبة المبيعات والارباح التجارية والصناعية وضريبة كسب العمل وطباعة الاقرارات الضريبية - مراقبة المخازن ومتابعة كروت الصنف وتسعير المنصرف بثلاثة طرق ( الوارد اولا يصرف اولا – المتوسط المرجح – اخر سعر ) - امكانية قرائة وطباعة الباركود وبدون الحاجة لطابعة خاصة - حسابات النقدية بالصندوق والبنوك وتعدد العملات - تكاليف الاستيراد وحساب تكلفة المشتريات المستوردة - حسابات تكاليف خطوط الانتاج وحساب تكلفة الوحدة من المنتجات - تعدد المستخدمين للبرنامج وصلاحيات خاصة لكل مستخدم وسهولة اضافة وحذف مستخدم وسهولة تعديل الصلاحيات - امكانية اضافة مجموعة شركات داخل البرنامج وكلمة مرور لكل شركة - يصلح البرنامج للعمل فى مصر وفى دول الخليج العربي - البرنامج يشمل روابط شرح تفصيلى لكل اجزائه واسم المستخدم وكلمة السر admin 123 وهذا هو البرنامج: بارك الله فيكم The_fastest.rar1 point
-
1 point
-
يمكنك استعمال هذا الكود في حدث عند الضغط على الزر Private Sub CommandButton1_Click() Dim iRow As Long, Lastrow As Long, i As Long With ورقة1 Lastrow = .Cells(.Rows.Count, 7).End(xlUp).Row For r = 3 To Lastrow If .Cells(r, 7) = TextBox1.Value Then iRow = .Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Row .Cells(iRow, 3).Value = Me.TextBox1.Value .Cells(iRow, 4).Value = Me.TextBox2.Value MsgBox " لقد تم الترحيل بنجاح ", vbExclamation + vbMsgBoxRight, "تم الترحيل " GoTo 1 End If Next End With MsgBox "لايوجد هذا الاسمً ", vbInformation + vbMsgBoxRight, "تنبيه" 1: TextBox1.Value = "" TextBox2.Value = "" TextBox1.SetFocus End Sub بالتوفيق1 point
-
بالنسبة لموضوع التنسيق الشرطي يمكنك كتابة نفس الشروط التي استعملتها على العمود L الذي تظهر فيه حالة العقد1 point
-
لا أدري أين المشكلة عندك ولكن إذا كنت تريد تطبيق ذلك على ملف آخر بامتداد xlsb أولا تفتح شاشة الفيجوال بيسك داخل اكسل ثم تضيف موديول جديد وتلصق فيه الكود الذي يتحقق من رقم الماذربورد Function MBSerialNumber(Optional strComputer As String = ".") As String Dim v, vName, vUUID With GetObject("winmgmts:\\" & strComputer & "\root\cimv2") For Each v In .ExecQuery("SELECT * FROM Win32_ComputerSystemProduct", , 48) vName = v.Name: vUUID = v.UUID Next v End With MBSerialNumber = vName & ", " & vUUID End Function ثم تضغط دبل كلك على thisworkbook وتلصق هذا الكود في حدث عند فتح الملف Private Sub Workbook_Open() Dim strMB1 As String, strMB2 As String, strMB3 As String 'Put Your MotherBoard Serial strMB1 = "HP ProDesk 490 G1 MT, FF004080-EE39-11E3-BFF8-A0D3C13F35B2" strMB2 = "HP Compaq 8500 Elite SFF PC, BFDEF800-AF9A-11E0-0000-2C27D742989F" strMB3 = "HP Compaq 8500 Elite SFF PC, BFDEF800-AF9A-11E0-0000-2C27D742989F" Select Case MBSerialNumber Case strMB1, strMB2, strMB3 Exit Sub Case Else MsgBox ("Data Security Failure. This Workbook Will Close") ActiveWorkbook.Close 1 End Select End Sub ثم تقوم بحفظ التغييرات وتغلق وتفتح الملف مرة أخرى بالتوفيق1 point
-
كود جميل جدا ولكن أنا شخصيا لا أدخل أهتم بموضوع أو استفسار لا يرفق معه صاحبه مثالا على المطلوب مع توضيح المطلوب بمنتهى الدقة والتفاصيل والنتائج المتوقعة عيدكم مبارك1 point
-
خلاص الحمدلله حصلت الإجابة على سؤالي شكرا لكم للإستفادة الدالة هي : Filter حيث انها تكون في اوفيس 365 واوفيس 2022 لاحقاً حسب علمي إن شاء الله. =FILTER(الزبائن!$E$5:$E$20000;الزبائن!$O$5:$O$20000=E3;"")1 point
-
مرحبا اخي لا اعلم اين المشكلة ..لكن قد تكون لديك بيانات اضافية في ملفك الاساسي1 point
-
1 point
-
حسب فهمي للمطلوب جرب هذه المعادلة في الخلية L26 =IFERROR(IF(AND(M26<>"",M26<I26),"سداد مبكر",IF(TODAY()=I26,"العقد انتهى اليوم",IF(TODAY()>I26,"العقـد منتهى",IF(TODAY()<H26,"لم يتم تداولة","العقـد سارى")))),"") تم تعديل الشرط الأول إلى ألا تكون الخلية فارغة وتكون أقل من تاريخ نهاية العقد1 point
-
1 point
-
بالاضافة الى ما تفضل به استاذنا الفاضل @د.كاف يار وله جزيل الشكر تفضل اخي الكريم جرب الكود التالي 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 تحياتي1 point
-
وعليكم السلام ورحمة الله وبركاته جرب الكود التالي =Nz(DMax("int([رقم_القيد])";"السيارات");0)+1 وهو يعمل اذا كان الحقل نص او رقم تحيايت1 point
-
جرب الكود الي اعطيتك هو لا تحاول تنفذ اشياء تصعب عليك جرب الكود الي اعطيتك هو و بعد التجربة احكم هل يأدي المصلحة او لا1 point
-
وأنا كل هالوقت اعتقد أنه زر وفي الأخير يطلع صندوق تسمية!!! شكرا يا @مسفر على كرم أخلاقك وردك على سؤالي. أخي أيو الحسن مشكلتك كانت من شقين أولهما أمر requery لا أعرف ترجمته الصحيحة ولكنه إعادة لتحميل البيانات والآخر هو استخدامك لصندوق التسمية فهو لا يستجيب عند النقر عليه باختيار السجل وقد عمل على صندوق النص وزر الأمر.1 point
-
1 point
-
1 point
-
جاري محاولة تطويرة ...... هل طبق ماهو مكتوب في بداية الموضوع ؟؟؟؟؟ اخي الكريم موجودة كل الملفات في بداية الموضوع .... بشرط طبق ما في الشرح !!1 point
-
1 point
-
جرب هذا الماكرو لا تنسى بانشاء مجلد backup في درايف c Sub savefile() Dim Path As String Dim Filename As String Path = "C:\backup\" Filename = Range("B3") ThisWorkbook.Sheets.Copy Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=Path & Filename & ".xlsx", FileFormat:=51 Application.DisplayAlerts = True ActiveWorkbook.Close True End Sub1 point
-
في مثل هذه الحالات يمكنك تسجيـل ماكرو وتفعل ما تريد وستحصل على الكود وتعدله كما تشاء1 point
-
1 point
-
تفضل ::::: وهذ هو الكود الذي تحدث عنه أخي @ mohamedd2003 On Error Resume Next Langauge ELanguage.Ar Dim fOK As Boolean Dim strTemp As String Forms!whatsapp.SetFocus strTemp = Me.txtMessage fOK = SetClipboardData_clt(strTemp) '========================================================================================================= Langauge ELanguage.en Application.FollowHyperlink "https://wa.me/" & txtNumbers auseTime = 40 start = Timer Do While Timer < start + auseTime DoEvents Loop Call SendKeys("~", True) Call SendKeys("{Enter}", True) Call SendKeys("^v", True) Call SendKeys("{Enter}", True) '=========================================================================================================== MsgBox "تم الارسال للرقم المطلوب"1 point
-
1 point
-
1 point
-
1 point