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

تفضل هذا التعديل Create Folder .accdb

اتفضل

Please be precise when posting a question as the rgb values should be 225 not 255 Sub Test() Dim r As Long, m As Long, cnt As Long Application.ScreenUpdating = False m = Cells(Rows.Count, 1).End(xlUp).Row For r = m To 2 Step -1 If Cells(r, 1).Interior.Color = RGB(225, 225, 225) Or Cells(r, 1).Interior.Color = RGB(192, 192, 192) Or (Cells(r, 1).Value = "" And Cells(r, 2).Value = "") Then Cells(r, 1).Resize(1, 2).Delete Shift:=xlUp cnt = cnt + 1 End If Next r Application.ScreenUpdating = True MsgBox "There Are " & cnt & " Rows Deleted", 64 End Sub

استخدم DMax DMax ( expression, domain, [criteria] ) ففي حالة انك تريد استكمال لسلسلة الأرقام لديك في الجدول استخدم التالي expression >>>> المعيار او اسم حقل الترقيم domain >>>> اسم الجدول Nz(DMax ( expression, domain),0)+1

هذه خاصة بالإكسل البديل عنها في الاكسس هي DCount DCount ( expression, domain, [criteria] ) مثال على ذلك DCount("UnitPrice", "Order Details", "OrderID = 10248") كذلك DCount("*", "Order Details", "OrderID = 10248") ففي المثال الخاص بك تم استخدام نفس الدالة للحصول على عدد الطلاب الحاصلين على مجموع درجات تتراوح من 70 الى 90 درجة DCount("*";"[Table1]";"[Number] Between 70 And 90") كذلك للحصول على نسبة هذه الشريحة من الطلاب استخدمنا التالي DCount("*";"[Table1]") ... اجمالي عدد الطلاب DCount("*";"[Table1]";"[Number] Between 70 And 90") ... اجمالي الطلاب الحاصلين على مجموع درجات تتراوح من 70 الى 90 درجة DCount("*";"[Table1]";"[Number] Between 70 And 90")/DCount("*";"[Table1]") .... النتيجة كذلك يمكنك انشاء دالة مشابهة في وظائفها لتلك التي في الاكسل COUNTIF Public Function COUNTIF(criteria As Variant) As Integer COUNTIF = DCount("*", "Table1", "Number" & criteria) End Function و تستخدم بالطريقة التالية COUNTIF(">50")

السلام عليكم ورحمة الله استخدم هذا الكود اسرع و افضل Sub الصف_الخامس() Dim LR As Long, erow As Integer, sh28 As Worksheet, sh22 As Worksheet, i As Long Dim Arr As Variant, Tmp As Variant, p As Long t = Timer Application.ScreenUpdating = False Set sh28 = Worksheets(" ملف وتحريري نصف العام صف خامس") Set sh22 = Worksheets("شيت صف خامس") sh22.Range("B14:CZ1000").ClearContents LR = sh28.Cells(Rows.Count, 2).End(xlUp).Row Arr = sh28.Range("B14:EE" & LR).Value ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 1) <> Empty Then p = p + 1 For j = 1 To 32 Tmp(p, Choose(j, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 16, 26, 36, _ 46, 48, 58, 83, 87, 91, 95, 99, 103, 17, 27, 37, 47, 59, 104)) = Arr(i, _ Choose(j, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 116, 117, 118, 119, _ 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133)) 'Tmp(p, 1) = p Next End If Next If p > 0 Then sh22.Range("B14").Resize(p, UBound(Tmp, 2)).Value = Tmp Application.ScreenUpdating = True 'MsgBox Round(Timer - t, 2) End Sub

جرب هذا .... Worker.rar

تم بفضل الله شكرا لاقتراحكم

استخدم Environ("USERPROFILE") & "\Desktop\" & fldrname

تفضل هذا الذي تمكنت من استعادته اتمنى ان يفي بالغرض adel2.rar

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

34 - عرض رسالة لتحديد تاريخ ووقت وتحديد احدهما افتراضياً. صورة لفهم المحتوى وقاعدة بيانات بها مثال لطريقة العمل . 34 - Msgbox With DateTime Picker with Checked.accdb ولا تنسي ان تسترد الكلاس الموجود لبرنامجك لانه سوف يبني عليه باقي السلسلة . بالتوفيق . كريم الحسيني .

33 - عرض رسالة لتحديد تاريخ ووقت وتحديد اى منهما . صورة لفهم المحتوى وقاعدة بيانات بها مثال لطريقة العمل . 33 - Msgbox With DateTime Picker with Check.accdb ولا تنسي ان تسترد الكلاس الموجود لبرنامجك لانه سوف يبني عليه باقي السلسلة . بالتوفيق . كريم الحسيني .

32 - عرض رسالة لتحديد تاريخ ووقت مع قيم افتراضية . صورة لفهم المحتوى وقاعدة بيانات بها مثال لطريقة العمل . 32 - Msgbox With DateTime Picker.accdb ولا تنسي ان تسترد الكلاس الموجود لبرنامجك لانه سوف يبني عليه باقي السلسلة . بالتوفيق . كريم الحسيني .

31 - عرض رسالة لتحديد تاريخ مع تاريخ افتراضي . صورة لفهم المحتوى وقاعدة بيانات بها مثال لطريقة العمل . 31 - Msgbox With Date Picker With a default Value.accdb ولا تنسي ان تسترد الكلاس الموجود لبرنامجك لانه سوف يبني عليه باقي السلسلة . بالتوفيق . كريم الحسيني .

30 - عرض رسالة لتحديد تاريخ . صورة لفهم المحتوى وقاعدة بيانات بها مثال لطريقة العمل . 30 - Msgbox With Date Picker.accdb ولا تنسي ان تسترد الكلاس الموجود لبرنامجك لانه سوف يبني عليه باقي السلسلة . بالتوفيق . كريم الحسيني .

أحسنت وبارك الله فيك ان شاءالله يكون هذا ما طلبه الاخ احمد. لك كل التحية والاحترام .

أعتقد أن الحل المشار إليه لحجم الاسطوانة الرأسية وليست الأفقية بالنسبة للأفقية نصف القطر في الخلية A2 ارتفاع السائل في الخلية B2 طول الاسطوانة في الخلية C2 وهذه معادلة الحجم =C2*(ACOS((A2-B2)/A2)*A2^2-(A2-B2)*SQRT(2*A2*B2-B2^2)) بالتوفيق

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

السلام عليكم ورحمة الله استخدم تلك المعادلة =SUMIFS($F$14:$F$35;$I$14:$I$35;"مدفوع")

تفضل اخى الكريم example-1.xlsx

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

ضع رقم المعرف في الخلية B2 من خلال القائمة في العمود E ملاحظة : يمكنك مسح القائمة فقط لتجربة الكود كيف يعمل. كما يوجد خلايا مدمجة لتجنب اي مشاكل مستقبلية قد تحدث خطا في الكود نتيجة الخلايا المدمجة خصوصا خلية رقم الهوية يجب الغاء دمجها اخيرا نظرا لسرية المعلومات يجب حماية محرر الاكواد برقم سري حتى لا يستطيع احد الولولج من داخله واظهار الاوراق . تحياتي hide specific sheets.xlsm

لإنشاء مجلد جديد استخدم الكود التالي Dim fso As Object, fldrname As String, fldrpath As String fldrname = " ضع هنا اسم المجلد " Set fso = CreateObject("scripting.filesystemobject") fldrpath = CurrentProject.Path & "\" & fldrname If Not fso.FolderExists(fldrpath) Then fso.createfolder (fldrpath) End If

تفضل أخي .. إشراف (1).accdb

أعتقد حتى الآن لم يتم كسر حماية الإصدار 25 لذا يمكنك استعمال إصدار أقدم

وعليكم السلام ورحمه الله وبركاته ارفق ملف اخى الكريم واشرح به ما تريد بالصور حتى يتسنى للاخوة المساعده وفهم المطلوب اكتر

السلام عليكم ورحمة الله الكود التالى يقوم بانشاء ورقة جديدة فى خالة عم وجودها Sub CrNewSheets() Dim dic As Object, Tmp As Variant, Itm Dim i As Long, Bok As Worksheet Set Bok = Sheets("BASS") Set dic = CreateObject("scripting.dictionary") Tmp = Bok.Range("E5:E" & Bok.Range("C" & Rows.Count).End(3).Row).Value For i = 1 To UBound(Tmp) dic(Tmp(i, 1) & "") = "" Next On Error Resume Next For Each Itm In dic.keys If Len(Trim(Itm)) > 0 Then If Len(Worksheets(Itm).Name) = 0 Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = Itm End If End If Next End Sub ضعى هذه العبارة فى اول سطر فى الكود المدرج بمشاركتى الاولى Call CrNewSheets و الزر يخصص للكود الاول فقط

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

واتفضل هذا مثال فقط ينقصه اعادة ربط الجداول المرتبطة من قاعدة الخلفية فقط حتى يعمل النسخ الاحتياطى على اكمل وجه frontend.mdb db.mdb

اتفضل يا سيدى جرب الكود الاتى ورد على من فضلك هل تم تنفيذ النسخ التلقائى لقاعدة بيانات الجداول ملاحظة هامة لن تحتاج لتحديد مسار قاعدة البيانات الخلفية ولا لتعديل اى شئ فقط استخدم الكود الاتى ,, كذلك وضعت تقريبا شرح لكل شئ على الكود '-----------------------------------------------------------' '-----------------------------------------------------------' ' _ +-----------officena-----------+ _ ' ' /o) | ||||| | (o\ ' ' / / | @(~O^O~)@ | \ \ ' ' ( (_ | _ ----oOo--Moh--oOo----- _ | _) ) ' ' ((\ \) +/o)----------3ssam---------(o\+ (/ /)) ' ' (\\\ \_/ / \ \_/ ///) ' ' \ / \ / ' ' \____/________Mohammed Essam________\____/ ' '--25-10-2021-----------------------------------------------' '-----------------------------------------------------------' Option Compare Database Option Explicit Function RunSub() Dim dbs As DAO.Database Dim tdf As DAO.TableDef Dim strPathDB As String Dim strNameExtensionDB As String Dim strNameDB As String Dim strExtensionDB As String Dim strBackupPath As String Dim strNewNameBackupDB As String Dim fso As Object Dim Syso As Object Set dbs = CurrentDb() With dbs For Each tdf In .TableDefs 'Is the table a linked table? If tdf.Attributes And dbAttachedODBC Or tdf.Attributes And dbAttachedTable Then With tdf 'Connect property contains path of link strPathDB = .Properties("Connect").Value 'Path of linked database tables strPathDB = Replace(strPathDB, ";DATABASE=", vbNullString) End With End If Next tdf End With 'Backup path directory strBackupPath = CurrentProject.Path & "\Backup\" Set fso = CreateObject("scripting.filesystemobject") 'Create the Backup folder if it does not exist If Not fso.FolderExists(strBackupPath) Then fso.createfolder (strBackupPath) 'Database name with extension strNameExtensionDB = Right(strPathDB, Len(strPathDB) - InStrRev(strPathDB, "\")) 'Database name without extension strNameDB = Left(strNameExtensionDB, InStrRev(strNameExtensionDB, ".") - 1) 'extension only strExtensionDB = Right(strPathDB, Len(strPathDB) - InStrRev(strPathDB, ".")) 'New name for backup database strNewNameBackupDB = strNameDB & "-Backup-" & Format(Now, "mm-yyyy") & "." & strExtensionDB 'Backup database save path directory strBackupPath = strBackupPath & strNewNameBackupDB DBEngine.Idle 'Copy the backup database to its directory Set Syso = CreateObject("Scripting.FileSystemObject") Syso.copyfile strPathDB, strBackupPath Set Syso = Nothing DoCmd.RunCommand acCmdExit End Function

طريق لغه البرمجه VBA - اين انت منه ؟ فارق السرعات بين التعامل مع خلايا ورقة العمل والمصفوفات رابط الجزء الاول من سلسله من اين ابدأ -انتظروا الجزء الثاني من هذه السلسله قريباً ان شاء الله - المرفقات VBA Road.rar

لغير متابعي موضوع ( VLOOKUP ) من البداية حتى الاحتراف حيث تعرضنا فية للدالة INDIRECT شرح الدالة INDIRECT INDIRECT.rar ........................................................... اتمنى ان يمثل الملف إضافة بسيطة