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

السلام عليكم الأخوة المبتدئين في برمجة الاكسس اضع بين ايديكم فيديو شرح لطرقة عمل تصفية وفلتر من خلال التقرير بدون اكواد ولا ازرار ولا شيء فقط من خلال التقرير شاهدوا هذا الفيديو لطفا يمنع دخول الخبراء هههههههه report.rar

يمكن الغاء مكرر من الكود ss = " مكرر": RNK = i - 1: Exit For استبدلها ss = " ": RNK = i - 1: Exit For

أخي عدلت لك المثال يعتمد على فراغ مربع نص ops في حالات: بعد تحديث ops ، عند فتح نموذج ، عند تنقل بين سجلات يعني عند تنقل بين سجلات و وصلت المربع فارغة يتم تمكين الصفحة و الا يتم الغاء تمكينها، FF.mdb

شكرا لكم اخوتي، لا يهم ان يكتب كلمة مكرر ولكن الترتيب اول ثاني ثالث او اول اول ثالث... قمت بتنزيل الملف المرفق وسأحاول البحث عن الحل واشارككم النتيجة ان شاء الله

السلام عليكم اوافق استاذتا ابو عيد على ما تفضل به ولكن احيانا لائحة الدراسة والامتحانات تنص على هذه الطريقة على كل حال من اكواد وكنوز المنتدى فيه طلبك ان شاء الله ترتيب التلاميذ تصاعديا (1).xlsm

السلام عليكم ورحمة الله تعالى وبركاته الموضوع بخصوص انشاء مجلدات الموضوع مطروح للتجربه والنقاش بفكره جديده تشمل كل الاحتمالات تقريبا التى خطرت على بالى الاكواد فى وحدة نمطيه عامة كالاتى ' استيراد كائن FileSystemObject Private fso As Object ' تهيئة كائن FileSystemObject Private Sub InitializeFSO() If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject") End If End Sub ' فحص وجود مجلد باستخدام FileSystemObject Private Function FolderExists(path As String) As Boolean InitializeFSO FolderExists = fso.FolderExists(path) End Function ' إنشاء بنية مجلدات متدرجة Private Function CreateFolderStructure(fullPath As String, ByRef errorMessage As String) As Boolean On Error GoTo ErrorHandler Dim parts() As String Dim currentPath As String Dim i As Integer ' تقطيع المسار إلى أجزاء parts = Split(fullPath, "\") currentPath = "" ' إنشاء كل جزء من المسار بشكل متدرج For i = LBound(parts) To UBound(parts) If parts(i) <> "" Then currentPath = currentPath & parts(i) & "\" If Not FolderExists(currentPath) Then fso.CreateFolder currentPath End If End If Next CreateFolderStructure = True Exit Function ErrorHandler: ' تخزين رسالة الخطأ في حال حدوث مشكلة errorMessage = "تعذر إنشاء المجلد: " & fullPath & " - الخطأ: " & Err.Description CreateFolderStructure = False End Function ' بناء مسار كامل من المسار الأساسي والمسار الفرعي Private Function BuildPath(basePath As String, subPath As String) As String ' التأكد من انتهاء المسار الأساسي بشرطة ميل (/) If Right(basePath, 1) <> "\" Then basePath = basePath & "\" ' استبدال شرط الميل ("/") بشريط الميل ("\") BuildPath = basePath & Replace(subPath, "/", "\") End Function ' تنظيف المسار وإصلاح الأخطاء الشائعة Function BuildFullPath(rawPath As String) As String Dim cleanPath As String ' إزالة الفراغات الزائدة واستبدال الرموز غير الصحيحة cleanPath = Trim(rawPath) cleanPath = Replace(cleanPath, "/", "\") ' تصحيح الأخطاء في بداية المسار (C\Test ? C:\Test) If Len(cleanPath) >= 2 And Mid(cleanPath, 2, 1) = "\" And (Asc(UCase(Left(cleanPath, 1))) >= 65 And Asc(UCase(Left(cleanPath, 1))) <= 90) Then cleanPath = Left(cleanPath, 1) & ":\" & Mid(cleanPath, 3) End If ' التحقق مما إذا كان المسار يبدأ بحرف قرص (مثل C:) لكنه لا يحتوي على \ بعده، وإصلاحه If Len(cleanPath) >= 2 And Mid(cleanPath, 2, 1) = ":" And Mid(cleanPath, 3, 1) <> "\" Then cleanPath = Left(cleanPath, 2) & "\" & Mid(cleanPath, 3) End If If Len(cleanPath) >= 2 And Mid(cleanPath, 2, 1) = "\" Then cleanPath = Left(cleanPath, 1) & ":\" & Right(cleanPath, Len(cleanPath) - 2) End If ' إذا لم يحتوي المسار على رمز قرص أو مسار شبكة، يتم ربطه بمسار المشروع الحالي If InStr(cleanPath, ":") = 0 And Left(cleanPath, 2) <> "\\" Then cleanPath = CurrentProject.path & "\" & cleanPath If Left(cleanPath, 1) = ":" Then cleanPath = CurrentProject.path & "\" & cleanPath ' تصحيح الأخطاء في كتابة المسارات cleanPath = Replace(cleanPath, "\:\", "\\") cleanPath = Replace(cleanPath, "\::\", "\") cleanPath = Replace(cleanPath, "\:", "\") ' استبدال \\ بـ \ باستثناء مسارات الشبكة \\Server\Share If Left(cleanPath, 2) <> "\\" Then cleanPath = Replace(cleanPath, "\\", "\") ' إرجاع المسار النظيف BuildFullPath = cleanPath End Function ' إنشاء مجلدات بناءً على قائمة مسارات فرعية Public Function CreateFolders(basePath As String, ParamArray folderPaths() As Variant) As String On Error GoTo ErrorHandler Dim path As Variant Dim fullPath As String Dim errorMessage As String InitializeFSO ' التحقق من وجود المسار الأساسي وإنشاؤه إذا لم يكن موجودًا If Not FolderExists(basePath) Then CreateFolderStructure basePath, errorMessage If errorMessage <> "" Then CreateFolders = errorMessage Exit Function End If End If ' إنشاء المسارات الفرعية For Each path In folderPaths fullPath = BuildPath(basePath, CStr(path)) If Not CreateFolderStructure(fullPath, errorMessage) Then CreateFolders = errorMessage Exit Function End If Next CreateFolders = "Success" Exit Function ErrorHandler: CreateFolders = "خطأ " & Err.Number & ": " & Err.Description End Function ' إنشاء مجلدات بناءً على بيانات جدول في قاعدة البيانات Public Function CreateFoldersFromTable(tableName As String, basePathField As String, Optional condition As String = "") As String On Error GoTo ErrorHandler Dim db As DAO.Database Dim rs As DAO.Recordset Dim query As String Dim basePath As String Dim folderPath As String Dim errorMessage As String Set db = CurrentDb() ' بناء استعلام لاستخراج المسارات الفريدة query = "SELECT DISTINCT [" & basePathField & "] FROM [" & tableName & "]" If condition <> "" Then query = query & " WHERE " & condition Set rs = db.OpenRecordset(query, dbOpenSnapshot) ' التحقق من وجود سجلات If rs.BOF And rs.EOF Then CreateFoldersFromTable = "لا توجد سجلات." Exit Function End If ' إنشاء المجلدات لكل سجل Do While Not rs.EOF basePath = Nz(rs.Fields(basePathField).Value, "") folderPath = BuildFullPath(basePath) ' التحقق من صحة المسار وإنشاؤه If Not CreateFolderStructure(folderPath, errorMessage) Then CreateFoldersFromTable = errorMessage Exit Function End If rs.MoveNext Loop ' إغلاق السجلات وتنظيف الذاكرة rs.Close Set rs = Nothing Set db = Nothing CreateFoldersFromTable = "Success" Exit Function ErrorHandler: CreateFoldersFromTable = "خطأ " & Err.Number & ": " & Err.Description End Function ويتم الاستدعاء حسب خيال المبرمج وهذه امثله لصور الاستدعاء ' إنشاء مجلدات يدويا ً من خلال تمرير المسار Sub Example1() Dim result As String result = CreateFolders("C:\Project Resources", _ "Backup", _ "Fonts\Arabic", _ "Fonts\English", _ "Images\Ico", _ "Images\Logo", _ "Images\QR Code", _ "PDF", _ "Utility\Reference\MsAccess", _ "Utility\Reference\TBL") If result = "Success" Then MsgBox "تم إنشاء المجلدات بنجاح!", vbInformation Else MsgBox "فشل في إنشاء المجلدات: " & result, vbCritical End If End Sub ' إنشاء مجلدات داخل مشروع Access الحالي Sub Example2() Dim result As String result = CreateFolders(CurrentProject.path & "\Project Resources", _ "Backup", _ "Fonts\Arabic", _ "Fonts\English", _ "Images\Ico", _ "Images\Logo", _ "Images\QR Code", _ "PDF", _ "Utility\Reference\MsAccess", _ "Utility\Reference\TBL") If result = "Success" Then MsgBox "تم إنشاء المجلدات داخل مشروع Access!", vbInformation Else MsgBox "حدث خطأ أثناء إنشاء المجلدات: " & result, vbCritical End If End Sub ' إنشاء مجلدات من جدول في قاعدة البيانات Sub Example3() Dim result As String result = CreateFoldersFromTable("tblFolderPaths", "FolderPath") If result = "Success" Then MsgBox "تم إنشاء المجلدات بنجاح!", vbInformation Else MsgBox "فشل في إنشاء المجلدات: " & result, vbCritical End If End Sub ' إنشاء مجلدات بناءً على فئة معينة Sub Example4() Dim result As String result = CreateFoldersFromTable("tblFolderPaths", "FolderPath", "Category = 'Access'") If result = "Success" Then MsgBox "تم إنشاء المجلدات الخاصة بمكتبات Access!", vbInformation Else MsgBox "فشل في إنشاء المجلدات: " & result, vbCritical End If End Sub ' إنشاء مجلدات شبكة (UNC Paths) Sub Example5() Dim result As String result = CreateFoldersFromTable("tblNetworkPaths", "UNCPath") If result = "Success" Then MsgBox "تم إنشاء المجلدات الشبكية بنجاح!", vbInformation Else MsgBox "حدث خطأ أثناء إنشاء المجلدات الشبكية: " & result, vbCritical End If End Sub ' إنشاء مجلدات شبكة بناءً على خادم معين Sub Example6() Dim result As String result = CreateFoldersFromTable("tblNetworkPaths", "UNCPath", "Server = 'FileServer01'") If result = "Success" Then MsgBox "تم إنشاء المجلدات على FileServer01!", vbInformation Else MsgBox "فشل في العثور على مجلدات لهذا الخادم: " & result, vbCritical End If End Sub ' إنشاء مجلدات بناءً على مدخلات المستخدم Sub Example7() Dim userCategory As String userCategory = InputBox("أدخل اسم الفئة لإنشاء المجلدات:", "تحديد الفئة") If userCategory <> "" Then Dim result As String result = CreateFoldersFromTable("tblFolderPaths", "FolderPath", "Category = '" & userCategory & "'") If result = "Success" Then MsgBox "تم إنشاء المجلدات للفئة: " & userCategory, vbInformation Else MsgBox "فشل في إنشاء المجلدات: " & result, vbCritical End If Else MsgBox "لم يتم إدخال فئة صحيحة!", vbExclamation End If End Sub الهدف: إنشاء مجلدات ديناميكيًا في مسار أساسي باستخدام معلومات مدخلة يدوية أو مستخلصة من قاعدة بيانات الحالات المختلفة للاستدعاء: الحالة 1: استدعاء دالة لإنشاء مجلد /هيكل المجلدات يدويا ً من خلال تمرير المسار الحالة 2: استدعاء دالة لإنشاء مجلد /هيكل المجلدات في مجلد مشروع Access الحالي الحالة 3: استدعاء دالة لإنشاء مجلد /هيكل المجلدات من خلال مسارات من جدول قاعدة بيانات الحالة 4: استدعاء دالة لإنشاء مجلد /هيكل المجلدات من خلال مسارات من جدول مع تصفية حسب فئة معينة الحالة 5: استدعاء دالة لإنشاء مجلد /هيكل المجلدات يدويا ً من خلال تمرير المسار الشبكي(UNC) الحالة 6: استدعاء دالة لإنشاء المجلدات من خلال مسارات من جدول مع تصفية حسب اسم الخادم المستخدم للمسار الشبكي (UNC) انشاء مجلد او هيكل مجلدات.zip

جرب هدا Option Explicit Sub SortData() Dim WS As Worksheet: Set WS = Sheets("ورقة1") Dim lastRow As Long, tmp As Long, col As Variant Application.ScreenUpdating = False tmp = 0 On Error Resume Next tmp = WS.Columns("B").Find("الإجمالي", LookIn:=xlValues, LookAt:=xlWhole).Row On Error GoTo 0 If tmp > 0 Then lastRow = tmp - 1 WS.Range("B4:E" & lastRow).Sort Key1:=WS.Range("E4:E" & lastRow), Order1:=xlAscending, Header:=xlNo End If For Each col In Array("C", "D", "E") With WS.Cells(tmp, col) .Formula = "=SUM(" & col & "4:" & col & lastRow & ")": .Value = .Value End With Next col Application.ScreenUpdating = True End Sub فرز عملاء.xlsm

وعليكم السلام ورحمة الله وبركاته ما تفضل به الاستاذ حجازي يكفى وفي تفس الوقت يمكن تعديل المعادلة لتعطى الخلية فارغة =IF($B$8="";"";IFERROR(1/(1/INDEX(Monthly1;$B$8;3));"")) الملف بدون اصفار الشهادات.xlsm

من قائمة ملف اختار خيارات ثم متقدم و افعل كما بالصورة

تفضل اخي الكريم Private Sub delz_AfterUpdate() If Len(Me.delz) > 0 Then Me.delz = Mid(Me.delz, 2) End If End Sub Private Sub Form_Load() Dim db As DAO.Database Set db = CurrentDb() db.Execute "UPDATE delz " & _ "SET delz = Mid(delz, 2) " & _ "WHERE delz IS NOT NULL AND Len(delz) > 1", dbFailOnError Set db = Nothing Me.Requery End Sub بدون تحديد الشرط 🤗 .

وعليكم السلام ورحمة الله وبركاته اظافة الى ما تفضل به استاذنا lionheart اضيف حل بالمعادلات اكنب الحرف المراد احصائه في الخلية D1 =LEN(A1)-LEN(SUBSTITUTE(A1;$D$1;"")) مثال عد الاحرف.xlsx

Put your string in cell A1 then run the following code that will list all the characters and their count in column C and D Sub Count_All_Characters() Dim ch, arrKeys, arrValues, ws As Worksheet, dict As Object, txt As String, i As Long Set ws = ActiveSheet Set dict = CreateObject("Scripting.Dictionary") txt = ws.Range("A1").Value For i = 1 To Len(txt) ch = Mid(txt, i, 1) dict(ch) = dict(ch) + 1 Next i With ws .Columns("C:D").ClearContents .Range("C1:D1").Value = Array("Character", "Count") If dict.Count > 0 Then arrKeys = dict.Keys arrValues = dict.Items .Range("C2").Resize(dict.Count, 1).Value = Application.Transpose(arrKeys) .Range("D2").Resize(dict.Count, 1).Value = Application.Transpose(arrValues) End If End With Set dict = Nothing MsgBox "Done", 64 End Sub

الحل بدوال vba ربما محترفي الإكسل عندهم حل بمعادلات الإكسل، أتمنى أن أرى مساهمات الأساتذة. UmAlqura4Excel_02.xlsm

قصدك اقوم معذرة ارفقت الملف الغلط يوجد يوزر فورم وورقة العقد كروت_08.xlsb

شكرا

Sub KH_START() Dim b As Integer, M As Integer Sheets("كشف ناجح").Range("c7:m1000").ClearContents Sheets("كشف الدور الثاني").Range("c7:m1000").ClearContents M = 7: b = 7 Application.ScreenUpdating = False For R = 1 To 1000 If InStr(1, Sheets("الشيت").Cells(R, 113).Value, "ناجح") Then Sheets("الشيت").Range("A" & R).Range("b1:c1,z1,ai1,ar1,ba1,bl1,bm1,cd1,di1,dj1").Copy Sheets("كشف ناجح").Range("c" & M).PasteSpecial xlPasteValues Application.CutCopyMode = False M = M + 1 End If If InStr(1, Sheets("الشيت").Cells(R, 113).Value, "دور ثان") Then Sheets("الشيت").Range("A" & R).Range("b1:c1,z1,ai1,ar1,ba1,bl1,bm1,cd1,di1,dj1").Copy Sheets("كشف الدور الثاني").Range("c" & b).PasteSpecial xlPasteValues Application.CutCopyMode = False b = b + 1 End If Next MsgBox ("الحمد لله تـــم ترحيل الناجحين و الراسبين إلى أوراق عمل جديدة ") Application.ScreenUpdating = True End Sub كود استدعاء رائع بتحسينات الاستاذ المحترم اسامه البراوي حفظه الله ترحيل مفيد باختبار اعمدة معينة 2.