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

اداة البحث هذه قمت بمحاولة تجميع الافكار فيها بعناية وبترتيبها لمحاولة الوصول الى اقصى درجات الكفائة والمرونة الممكنة اولا : تعرية وتطهير النص والتحكم فى ذلك حسب الحاجة كما سبق التنويه عن هذه الجزئية فى هذا الموضوع ثانيا : التحكم فى اعداد مصادر البيانت :- (مصدر البيانات"جدول /استعلام" - الحقولالبحث المخصصة - امكانية اضافة حقل او اكثر يعتمد على تطهير النصوص ثالثا : آلية البحث بحيث يمكن البحث من خلال ( الكلمة تبدأ بـ - تنتهى بـ - يتضمن الكلمة فى امكان - او متطابق تماما او لو عدد الكلمات كثير يمكن كتابة جزء من كل كلمة فى نفس السجل ولا يشترط الترتيب ) مثال : نريد البحث فى السجل قيمة هذا السجل : 26675 فوزي عبد الحميد ابو الفتوح محمد سعده لو تم اختيار من إعدادت البحث : يحتوى على اكثر من كلمة او جزء من كلمه يفصل بينهم مسافة من إعدادت البحث ثم كتبنا فى مربع البحث : عب فت سع 66 نحصل على النتيجة اثناء كتابة الكود تم عمل جدول باسم : tblSearchSettings بحيث يتم حفظ الاعدادت الخاصة بعملية البحث والفرز والتصفية تم وضع القيم الافتراضية لاجراء عمليات البحث والفرز والتصفية المتعددة على اكمل وجهة فى حالة حذف الجدول الخاص باعدادت البحث كما انها تمثل مرونة قصوى لكل مستخدم على حدى فى حالة استخدام شبكة محلية يستطيع كل مستخدم الاحتفاظ بالاعدادت التى تناسبه دون التأثير على الاخرين اخيرا المرفق واترككم مع التجربة Search Utility V 3.0.2.accdb

مشاركة مع الإخوة الأعزاء 🙂 هذه طريقتي في تضمين الخطوط في البرنامج .. 1- إرفاق الخطوط في البرنامج في جدول معد لذلك وبه حقل مرفقات : 2 - في الموديول كود يقوم باستخراج الخطوط ووضعها في مجلد بجانب قاعدة البيانات : 3 - يقوم الكود بتنصيب الخطوط تلقائيا بدون تدخل من المستخدم وذلك عن طريق الماكرو ( وبالمناسبة هو نفس الأمر الذي يستخرج الخطوط من الجدول ) 🙂 4- وبعدها ستجد أن الخطوط تعمل لديك بشكل جيد بدون مشاكل إن شاء الله 🙂 للتطبيق على برنامجك أنقل جميع العناصر لبرنامجك وغير الخطوط في الجدول . الملف : Add Fonts.accdb

تفضل ..... الكود لنقل الرقم فقط ...اعلمنا بالنتيجة .... Sub ExtractSingleNumber() Dim db As DAO.Database Dim rs As DAO.Recordset Dim strPattern As String Dim strInput As String Dim regExp As Object Dim matches As Object ' النمط لاستخراج الرقم بين & و && strPattern = "&(\d+)&&" ' تهيئة قاعدة البيانات Set db = CurrentDb Set rs = db.OpenRecordset("SELECT nass, page FROM book") ' تهيئة كائن التعبير النمطي Set regExp = CreateObject("VBScript.RegExp") regExp.Pattern = strPattern regExp.Global = False ' المرور عبر السجلات Do While Not rs.EOF strInput = rs!nass If regExp.Test(strInput) Then Set matches = regExp.Execute(strInput) rs.Edit rs!Page = matches(0).SubMatches(0) ' الرقم المستخرج rs.Update End If rs.MoveNext Loop ' تنظيف الموارد rs.Close Set rs = Nothing Set db = Nothing Set regExp = Nothing MsgBox "تم نسخ الأرقام إلى الحقل page بنجاح!" End Sub والكود التالي لحذف السطر الذي به النمط تفضل ...... Sub RemoveAllPatterns() Dim db As DAO.Database Dim rs As DAO.Recordset Dim strPattern As String Dim strInput As String Dim regExp As Object ' النمط لإزالة كل ما يشبه &رقم&& strPattern = "&\d+&&" ' تهيئة قاعدة البيانات Set db = CurrentDb Set rs = db.OpenRecordset("SELECT nass FROM book") ' تهيئة كائن التعبير النمطي Set regExp = CreateObject("VBScript.RegExp") regExp.Pattern = strPattern regExp.Global = True ' لضمان إزالة جميع التطابقات داخل النص ' المرور عبر السجلات Do While Not rs.EOF strInput = rs!nass If regExp.Test(strInput) Then rs.Edit ' إزالة جميع التطابقات للنمط من النص rs!nass = regExp.Replace(strInput, "") rs.Update End If rs.MoveNext Loop ' تنظيف الموارد rs.Close Set rs = Nothing Set db = Nothing Set regExp = Nothing MsgBox "تم حذف جميع الأنماط &رقم&& بنجاح!" End Sub

السلام عليكم ورحمة الله وبركاته اليوم اقدم لك وظيفة مُطَهَّرُ النُّصُوصِ الْعَرَبِيَّةِ غاية فى الروعة ومكتوبة بعناية واحترافية للحصول على اكبر قدر ممكن من الدقة فى الاداء والمرونة فى التناول عند الاستدعاء حيث أن الكود يعالج النصوص العربية بطريقة مرنة مع التركيز على ازالة المسافات وتنظيف النص و إزالة التشكيل و توحيد الاحرف ومعالجتها يعتمد الكود خيارين للعمل (إزالة المسافات أو التطبيع "توحيد الاشكال المختلفة للاحرف" ) مما يجعله قابلاً للتخصيص بناءً على الحاجة على سبيل المثال النص الاصلى والذى نريد معالجته : "تَجْرِبَةُ إِشْرَافٍ عَلَى? بَعْضِ الْأَمَاكِنِ أَوْ الْمَكَانِ رَقْمٌ 101" الحالات التى يمكن الحصول عليها من معالجة النص السابق هى ازالة المسافات فقط وتنظيف النص مع الابقاء على الارقام بدون التطبيع : تجربة إشراف على بعض الأماكن أو المكان رقم 101 ازالة المسافات وتنظيف النص مع الابقاء على الارقام مع التطبيع : تجربه اشراف علي بعض الاماكن او المكان رقم 101 ازالة المسافات وتنظيف النص مع ازالة الارقام مع التطبيع : تجربه اشراف علي بعض الاماكن او المكان رقم ازالة المسافات فقط وتنظيف النص مع ازالة الارقام بدون التطبيع : تجربة إشراف على بعض الأماكن أو المكان رقم الكود ' Function: ArabicTextSanitizer ' Purpose: Sanitizes Arabic text by removing non-Arabic characters, optionally normalizing the text, ' removing diacritics (harakat), and optionally removing numeric characters or spaces. ' Parameters: ' inputText (String): The Arabic text to be sanitized. It can contain Arabic characters, non-Arabic characters, ' diacritics, and numeric values. ' normalize (Boolean): Optional. If True, the text will be normalized by replacing specific Arabic characters ' with their standardized equivalents (default is True). ' RemoveNumbers (Boolean): Optional. If True, numeric characters (0-9) will be removed from the text (default is True). ' removeSpaces (Boolean): Optional. If True, all spaces in the text will be removed (default is False). ' Returns: ' String: The sanitized Arabic text with optional normalization, removal of numbers, and spaces. ' ' Example Use Cases: ' 1. Remove spaces only and clean the text while keeping numbers without normalization: ' ' Removes spaces from the text while keeping numbers and without normalizing the text. ' ' Example: ArabicTextSanitizer(inputArabicText, False, False, True) ' ' 2. Remove spaces and clean the text while keeping numbers and normalizing: ' ' Normalizes the text and removes spaces, while keeping numbers. ' ' Example: ArabicTextSanitizer(inputArabicText, True, False, True) ' ' 3. Remove spaces and clean the text while removing numbers and normalizing: ' ' Normalizes the text, removes spaces, and removes numbers. ' ' Example: ArabicTextSanitizer(inputArabicText, True, True, True) ' ' 4. Remove spaces only and clean the text while removing numbers without normalization: ' ' Removes spaces and numbers, but does not normalize the text. ' ' Example: ArabicTextSanitizer(inputArabicText, False, True, True) ' Public Function ArabicTextSanitizer(inputText As String, Optional normalize As Boolean = True, Optional RemoveNumbers As Boolean = True) As String On Error GoTo ErrorHandler ' Ensure the input is valid (non-empty and not null) If Nz(inputText, "") = "" Then ArabicTextSanitizer = "" Exit Function End If ' Initialize the sanitizedText with the trimmed input Dim sanitizedText As String sanitizedText = Trim(inputText) ' Step 1: Normalize the text if requested If normalize Then ' Define character replacement pairs for normalization Dim charReplacementPairs As Variant charReplacementPairs = Array( _ Array(ChrW(1573), ChrW(1575)), _ Array(ChrW(1571), ChrW(1575)), _ Array(ChrW(1570), ChrW(1575)), _ Array(ChrW(1572), ChrW(1608)), _ Array(ChrW(1574), ChrW(1609)), _ Array(ChrW(1609), ChrW(1610)), _ Array(ChrW(1577), ChrW(1607)), _ Array(ChrW(1705), ChrW(1603)), _ Array(ChrW(1670), ChrW(1580))) ' Apply replacements for character normalization Dim pair As Variant For Each pair In charReplacementPairs sanitizedText = Replace(sanitizedText, pair(0), pair(1)) Next ' Step 2: Remove diacritics (harakat) from the text Dim diacritics As String diacritics = ChrW(1600) & ChrW(1611) & ChrW(1612) & ChrW(1613) & ChrW(1614) & ChrW(1615) & ChrW(1616) & ChrW(1617) & ChrW(1618) Dim i As Integer For i = 1 To Len(diacritics) sanitizedText = Replace(sanitizedText, Mid(diacritics, i, 1), "") Next End If ' Step 3: Retain only Arabic characters, spaces, and optionally numbers Dim tempChars() As String Dim charIndex As Long Dim intChar As Integer Dim finalResultText As String ' Iterate through each character in the sanitized text For i = 1 To Len(sanitizedText) intChar = AscW(Mid(sanitizedText, i, 1)) ' Check for Arabic characters (range for Arabic characters and spaces) If intChar = 32 Or _ (intChar >= 1569 And intChar <= 1594) Or _ (intChar >= 1601 And intChar <= 1610) Or _ (intChar >= 1648 And intChar <= 1649) Then ReDim Preserve tempChars(charIndex) tempChars(charIndex) = ChrW(intChar) charIndex = charIndex + 1 ' Optionally, check for numbers if RemoveNumbers is False ElseIf Not RemoveNumbers And (intChar >= 48 And intChar <= 57) Then ReDim Preserve tempChars(charIndex) tempChars(charIndex) = ChrW(intChar) charIndex = charIndex + 1 End If Next ' Step 4: Join the valid characters into a final result text finalResultText = Join(tempChars, "") ' Step 5: Remove extra spaces (multiple consecutive spaces replaced with a single space) finalResultText = Replace(finalResultText, " ", " ") ' Improved space replacement Do While InStr(finalResultText, " ") > 0 finalResultText = Replace(finalResultText, " ", " ") Loop ' Step 6: Remove special characters (if needed) finalResultText = Replace(finalResultText, "*", "") finalResultText = Replace(finalResultText, "#", "") finalResultText = Replace(finalResultText, "@", "") finalResultText = Replace(finalResultText, ",", "") ' Return the sanitized text If Len(Trim(Nz(finalResultText, ""))) = 0 Then ArabicTextSanitizer = vbNullString Else ArabicTextSanitizer = finalResultText End If Exit Function ErrorHandler: Debug.Print "Error in ArabicTextSanitizer: " & Err.Description ArabicTextSanitizer = "" End Function وهذه الوظيفة تبين اشكال وطرق الاستدعاء المختلفة ' Subroutine: TestArabicTextSanitizer ' Purpose: Demonstrates and validates the functionality of the ArabicTextSanitizer function. ' It shows various test cases for sanitizing Arabic text with diacritics, non-Arabic characters, and numbers. Sub TestArabicTextSanitizer() ' Declare input and result variables Dim inputArabicText As String Dim result As String ' Example input text with diacritics, non-Arabic characters, and numbers inputArabicText = "تَجْرِبَةُ * فَاحِصِهِ # @ , لِعَمَلٍ أَلِكَوَّدِ فِىَّ شَتِّيَّ 3ألْإِشْكآل " & _ "إِشْرَافٍ عَلَى? بَعْضِ الْأَمَاكِنِ أَوْ الْمَكَانِ رَقْمٌ 5 و الْمَكَانِ رَقْمٌ 100100ِ لمعرفة كيف سيعمل ها ألكود" ' Display the original input Arabic text Debug.Print "Input Arabic Text: " & inputArabicText ' Test case 1: Remove diacritics without normalization ' This case removes diacritics (harakat) without altering normalization or removing numbers result = ArabicTextSanitizer(inputArabicText, False, False) Debug.Print "Filtered Arabic Text (case 1 - Remove diacritics without normalization): " & result ' Test case 2: Normalize and remove diacritics ' This case normalizes the text (e.g., converting similar Arabic characters) and removes diacritics result = ArabicTextSanitizer(inputArabicText, True, False) Debug.Print "Normalized Arabic Text and Removed Diacritics (case 2): " & result ' Test case 3: Remove numbers as well (Optional argument set to True to remove numbers) ' This case normalizes the text and removes both diacritics and numbers result = ArabicTextSanitizer(inputArabicText, True, True) Debug.Print "Text without Numbers and Normalized (case 3): " & result ' Test case 4: Just remove diacritics without normalization or removing numbers ' This case removes diacritics and numbers, but does not normalize the text result = ArabicTextSanitizer(inputArabicText, False, True) Debug.Print "Text without Diacritics and Numbers (case 4): " & result End Sub واخيرا اليكم مرفق للتجربة Arabic Text Sanitizer.accdb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Const Clé As String = "1234" ' قم بتعديل الباسوورد بما يناسبك Private Sub Worksheet_Change(ByVal Target As Range) Dim lastRow As Long lastRow = Cells(Rows.Count, "J").End(xlUp).Row ActiveSheet.Unprotect Clé If Not Intersect(Target, Me.Range("J7:J" & lastRow)) Is Nothing And Target.Columns.Count = 1 Then Application.EnableEvents = False Dim cell As Range For Each cell In Target If cell.Row >= 7 Then cell.Locked = Not IsEmpty(cell.Value) Next cell Application.EnableEvents = True End If ActiveSheet.Protect Clé, UserInterfaceOnly:=True End Sub '================================== Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim lastRow As Long, choose As String: Static OnRng As Range lastRow = Cells(Rows.Count, "J").End(xlUp).Row If Not Intersect(Target, Me.Range("J7:J" & lastRow)) Is Nothing Then If Not IsEmpty(Target.Value) Then If Target.Locked Then choose = InputBox(": خلية التوقيع محمية الرجاء إدخال كلمة المرور", ":إنتــباه") If choose = Clé Then ActiveSheet.Unprotect Clé If Not OnRng Is Nothing Then OnRng.Locked = True Target.Locked = False Set OnRng = Target ActiveSheet.Protect Clé, UserInterfaceOnly:=True ElseIf choose <> "" Then MsgBox "كلمة المرور غير صحيحة", vbExclamation, "خطأ" End If Else Set OnRng = Target End If Else ActiveSheet.Unprotect Clé Target.Locked = False Set OnRng = Nothing ActiveSheet.Protect Clé, UserInterfaceOnly:=True End If End If End Sub شيت حوافز تجريبى V2.xlsb

وعليكم السلام ورحمة الله وبركاته 🙂 عملت شيء مشابه لهذا سابقا .. فقط يمكن تعديله ليتوافق مع الحاجة 🙂 ‏‏Meter -Moosak _ Final.accdb

وعليكم السلام ورحمة الله تعالى وبركاته كما سبق الدكر من الأستاد @عبدالله بشير عبدالله طلبك غير واضح إظافة أن أرقام الأعمدة على الملف تتواجد في الصف 3 ليس 2 مجرد تخمين ربما تقصد جلب بيانات العمود بشرط إدخال قيمة رؤوس الأعمدة (رقم العمود) جرب هدا Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim OnRng As Variant, tmp As Variant, lastRow As Long, a As Long, Clé As String Dim WS As Worksheet: Set WS = Sheets("Sheet1") If Target.Cells.Count > 1 Then Exit Sub If Not Intersect(Target, WS.Range("AQ3:BO3")) Is Nothing Then lastRow = WS.Columns("A:Z").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row OnRng = WS.Range("A4:Z" & lastRow).Value tmp = WS.Range("A3:Z3").Value Clé = Target.Value Application.ScreenUpdating = False If IsEmpty(Target.Value) Then WS.Range(WS.Cells(4, Target.Column), WS.Cells(lastRow, Target.Column)).ClearContents Else For a = 1 To UBound(tmp, 2) If tmp(1, a) = Clé Then With WS.Range(WS.Cells(4, Target.Column), WS.Cells(lastRow, Target.Column)) .ClearContents .Value = Application.Index(OnRng, 0, a) End With Exit For End If Next a End If If a > UBound(tmp, 2) Then Target.ClearContents: MsgBox "لم يتم العثور على " & _ Target.Value & " في قاعدة البيانات", vbExclamation, "إنتبـــاه" End If Application.ScreenUpdating = True End Sub استخراج الاعمدة.xlsm

وعليكم السلام ورحمة الله وبركانه لم نوضح لنا مكان كتابة النتائج النهائية وكيف ترغب شكلها النهائي في الملف العمود c كلمة نطايق نعنى ان لها مثيل في العمودين d-e وفي العمود f كلمة نطايق نعنى ان لها مثيل في العمودين A - B الكود Sub CompareTablesInOneSheet() Dim ws As Worksheet Dim lastRow1 As Long Dim lastRow2 As Long Dim i As Long Dim j As Long Set ws = ThisWorkbook.Sheets("ورقة1") lastRow1 = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row lastRow2 = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row ws.Range("C2:C" & lastRow1).ClearContents ws.Range("F2:F" & lastRow2).ClearContents For i = 2 To lastRow1 For j = 2 To lastRow2 If ws.Cells(i, 1).Value = ws.Cells(j, 4).Value And ws.Cells(i, 2).Value = ws.Cells(j, 5).Value Then ws.Cells(i, 3).Value = "متطابق" ws.Cells(j, 6).Value = "متطابق" Exit For End If Next j If ws.Cells(i, 3).Value <> "متطابق" Then ws.Cells(i, 3).Value = "غير متطابق" End If Next i For j = 2 To lastRow2 If ws.Cells(j, 6).Value <> "متطابق" Then ws.Cells(j, 6).Value = "غير متطابق" End If Next j MsgBox "تم مقارنة البيانات بنجاح!" End Sub الملف Test.xlsb

وعليكم السلام ورحمه الله وبركاته ممكن تستخدم الكود التالي لعله المطلوب Sub ColorCellsAboveYellow() Dim ws As Worksheet Dim cell As Range Dim targetColor As Long Dim i As Integer Set ws = ThisWorkbook.Sheets("Sheet1") targetColor = RGB(255, 255, 0) For Each cell In ws.UsedRange If cell.Interior.Color = targetColor Then For i = 1 To 2 If cell.Row - i > 0 Then ws.Cells(cell.Row - i, cell.Column).Interior.Color = targetColor End If Next i End If Next cell End Sub Book1.xlsm

جرب هذا ........................ Sub CleanAndRemovePatterns() Dim db As DAO.Database Dim rs As DAO.Recordset Dim strPattern As String Dim strInput As String Dim updatedText As String Dim regExp As Object On Error GoTo ErrorHandler Set db = CurrentDb Set rs = db.OpenRecordset("SELECT ID, nass FROM book", dbOpenDynaset) strPattern = "&\d+&&" Set regExp = CreateObject("VBScript.RegExp") regExp.Pattern = strPattern regExp.Global = True Do While Not rs.EOF If Not IsNull(rs!nass) Then strInput = rs!nass updatedText = strInput If regExp.Test(updatedText) Then updatedText = regExp.Replace(updatedText, "") End If If Left(updatedText, 2) = vbCrLf Then updatedText = Mid(updatedText, 3) ElseIf Left(updatedText, 1) = vbLf Then updatedText = Mid(updatedText, 2) ElseIf Left(updatedText, 1) = vbCr Then updatedText = Mid(updatedText, 2) End If updatedText = LTrim(updatedText) If strInput <> updatedText Then rs.Edit rs!nass = updatedText rs.Update End If End If rs.MoveNext Loop rs.Close Set rs = Nothing Set db = Nothing Set regExp = Nothing MsgBox "تمت إزالة الأنماط والسطر الفارغ بنجاح!", vbInformation Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical If Not rs Is Nothing Then rs.Close Set rs = Nothing End If Set db = Nothing Set regExp = Nothing End Sub

اسمحوا لي مشاركتكم ،، فقد أعجبت بالفكرة استناداً إلى ملف الأستاذ @Moosak ، وإن سمح لي بالتعديل عليه لتوليفه حسب حاجة أخونا @Mr-X التعديلات بسيطة الى حد ما ، ولكنها لبت المطلوب في المرفق التالي DBSize.accdb

وعليكم السلام ورحمة الله تعالى وبركاته ادا كان هدا ما تقصده جرب هدا =IFERROR(TEXT(DATE(2000+LEFT(B2,2),MID(B2,3,2),RIGHT(B2,2)),"DD/MM/YYYY"),"") او Option Explicit Sub ConvertDate() Dim lr As Long, r As Long, xDate As String, n As String Dim scWS As Worksheet: Set scWS = Sheets("Sheet1") lr = scWS.Cells(scWS.Rows.Count, "B").End(xlUp).Row For r = 2 To lr xDate = scWS.Cells(r, "B").Value If xDate <> "" Then n = Format(DateSerial(2000 + Left(xDate, 2), _ Mid(xDate, 3, 2), _ Right(xDate, 2)), "dd/mm/yyyy") scWS.Cells(r, "D").Value = n End If Next r End Sub New Microsoft Excel Worksheet.xlsx

يمكنك تعديل كود عرض الأعمدة بترتيب العناصر على الشكل التالي Private Sub ContrArr(tmp As Long) Dim controls As Variant, columns As Variant, i As Integer controls = Array("TextBox7", "ComboBox1", "ComboBox2", "ComboBox3", "ComboBox4", _ "TextBox3", "TextBox4", "TextBox5", "TextBox6", "ComboBox5") columns = Array(2, 4, 5, 6, 7, 8, 9, 10, 11, 12) If Me.TextBox8.Text = "" Then ClearControls Else Me.TextBox8.Tag = tmp For i = LBound(controls) To UBound(controls) Me.controls(controls(i)).Text = WS.Cells(tmp, columns(i)).Value Next i tblUpdate tmp End If End Sub البحث والتنقل.rar

For tmp = 6 To Irow If IsNumeric(SrcWS.Cells(tmp, "A").Value) Then SrcWS.Cells(tmp, "A").ClearContents End If Next tmp مطلوب ترقيم تلقائى لا يتأثر بحذف الصفوف.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك استخدام الكود التالي من المصنف الرئيسي وتحديث ملفات الإدارة دفعة واحدة بدون فتحها او تغيير تنسيقها يكفي وضعها في نفس مسار المصنف بحيث يتم تحديث البيانات عند التحقق من عدم وجود الرقم التأميني مسبقا على ملف الإدارة الهدف وتحديث عمود (م) وإظافة تاريخ التحديث في عمود ( تاريخ دخول القسم) Option Explicit Sub Departments_update() Dim WB As Workbook, destWB As Workbook, srcWS As Worksheet, destWS As Worksheet, _ iRow As Long, Rng As Range, dstRng As Long, lastRow As Long, Cnt As String, _ tmp As String, n As String, WSname As String, ShArr As Variant, j As Boolean, _ Updated As Boolean, nameFile As String, cell As Range, result As Boolean ShArr = Array("المستحقين", "احياء", "التفتيش", "اخرى") Cnt = "=SUBTOTAL(103,INDIRECT(ADDRESS(ROW(),COLUMN()+1)&"" :""&ADDRESS(ROW($E$7),COLUMN()+1)))" Updated = False result = False Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual Application.EnableEvents = False: Application.DisplayAlerts = False Set WB = ThisWorkbook For Each srcWS In WB.Worksheets If Not IsError(Application.Match(srcWS.Name, ShArr, 0)) Then WSname = srcWS.Name nameFile = WB.Path & "\" & WSname & ".xls" If Dir(nameFile) <> "" Then result = True Set destWB = Workbooks.Open(nameFile) Set destWS = destWB.Worksheets(WSname) If Not destWS Is Nothing Then For iRow = 7 To srcWS.Cells(srcWS.Rows.Count, "R").End(xlUp).Row n = srcWS.Cells(iRow, "R").Value If InStr(1, n, WSname, vbTextCompare) > 0 And n <> "" Then tmp = srcWS.Cells(iRow, "E").Value j = False lastRow = destWS.Cells(destWS.Rows.Count, "E").End(xlUp).Row For Each cell In destWS.Range("E7:E" & lastRow) If cell.Value = tmp Then j = True Exit For End If Next cell If Not j Then Set Rng = srcWS.Range(srcWS.Cells(iRow, 3), srcWS.Cells(iRow, 27)) dstRng = destWS.Cells(destWS.Rows.Count, "E").End(xlUp).Row + 1 If dstRng < 7 Then dstRng = 7 destWS.Cells(dstRng, "C").Resize(, 25).Value = Rng.Value destWS.Cells(dstRng, "D").Value = Date destWS.Cells(dstRng, "B").Formula = Cnt Updated = True End If End If Next iRow destWB.Close SaveChanges:=True Else destWB.Close SaveChanges:=False End If Set destWB = Nothing Set destWS = Nothing End If End If Next srcWS If result Then MsgBox IIf(Updated, "تم تحديث البيانات بنجاح", "جميع البيانات محدثة مسبقا"), vbInformation, "تعليمات" Else MsgBox "لم يتم العثور على أي ملفات خاصة بالإدارات", vbExclamation, "تنبيه" End If Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True: Application.DisplayAlerts = True Set WB = Nothing: Set srcWS = Nothing: Set Rng = Nothing: Set cell = Nothing End Sub ملفات الإدارة.rar ترحيل الصفوف مع عدم التكرار.rar

السلام عليكم بعد اذن استاذنا الفاضل محمد هشام يالنسبة لسؤالك اضغط على Ctrl + Shift + Enter اطلعت على ملفك وما قام به الاستاذ محمد هشام كاقي ووافي ولكن التعامل مع معادلات الصفيف تحتاج الى من ينتبه بحذر عند استخذام الملف لان ضباع الاقواس معناها نتائج خاطئة ارفق لك ملفا بواسطة كود يعمل تلقائيا عند الاختيار من القائمة الى جانب يقوم بتحديث القائمة اذا اضفت لها بيانا جديدا او اكثر DC.xlsb

وعليكم السلام ورحمة الله وبركاته الكود Sub CreateBackup() Dim wb As Workbook Dim folderPath As String Dim fileName As String Dim fileExtension As String Dim backupName As String Dim backupNumber As Integer Dim fso As Object Dim file As Object Set wb = ThisWorkbook folderPath = wb.Path & "\" fileName = Left(wb.Name, InStrRev(wb.Name, ".") - 1) fileExtension = Mid(wb.Name, InStrRev(wb.Name, ".")) Set fso = CreateObject("Scripting.FileSystemObject") backupNumber = 0 For Each file In fso.GetFolder(folderPath).Files If InStr(file.Name, fileName) = 1 And InStr(file.Name, fileExtension) > 0 Then Dim currentNumber As Integer On Error Resume Next currentNumber = CInt(Mid(file.Name, Len(fileName) + 1, InStrRev(file.Name, fileExtension) - Len(fileName) - 1)) On Error GoTo 0 If currentNumber > backupNumber Then backupNumber = currentNumber End If End If Next file backupName = folderPath & fileName & (backupNumber + 1) & fileExtension wb.SaveCopyAs backupName MsgBox "تم إنشاء نسخة احتياطية باسم: " & vbCrLf & backupName, vbInformation, "نسخة احتياطية" End Sub الملف Ehab.xlsb

DC.xlsx

السلام عليكم بعد اذن استالذنا أبومروان حل بواسطة المصقوفات الكود Sub ذكرين_انثيين() Dim ws As Worksheet Dim lastRow As Long Dim dataArray As Variant Dim males() As Variant Dim females() As Variant Dim resultArray() As Variant Dim maleCount As Long, femaleCount As Long Dim rowIndex As Long, i As Long, j As Long Set ws = ThisWorkbook.Sheets("ورقة1") lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row dataArray = ws.Range("A2:F" & lastRow).Value ReDim males(1 To UBound(dataArray, 1), 1 To UBound(dataArray, 2)) ReDim females(1 To UBound(dataArray, 1), 1 To UBound(dataArray, 2)) maleCount = 0 femaleCount = 0 For i = 1 To UBound(dataArray, 1) If dataArray(i, 6) = "ذكر" Then maleCount = maleCount + 1 For j = 1 To UBound(dataArray, 2) males(maleCount, j) = dataArray(i, j) Next j ElseIf dataArray(i, 6) = "انثى" Then femaleCount = femaleCount + 1 For j = 1 To UBound(dataArray, 2) females(femaleCount, j) = dataArray(i, j) Next j End If Next i ReDim resultArray(1 To maleCount + femaleCount, 1 To UBound(dataArray, 2)) rowIndex = 1 i = 1 j = 1 Do While i <= maleCount Or j <= femaleCount For k = 1 To 2 If i <= maleCount Then For col = 1 To UBound(dataArray, 2) resultArray(rowIndex, col) = males(i, col) Next col rowIndex = rowIndex + 1 i = i + 1 End If Next k For k = 1 To 2 If j <= femaleCount Then For col = 1 To UBound(dataArray, 2) resultArray(rowIndex, col) = females(j, col) Next col rowIndex = rowIndex + 1 j = j + 1 End If Next k Loop For i = 1 To UBound(resultArray, 1) resultArray(i, 1) = i ' الترقيم يبدأ من 1 Next i ws.Range("A2:F" & lastRow).ClearContents ws.Range("A2").Resize(UBound(resultArray, 1), UBound(resultArray, 2)).Value = resultArray MsgBox "تم الترتيب بنجاح !", vbInformation End Sub الملف فرز حسب الجنس بشروط.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته Sub MergeTotal() Dim WS As Worksheet, crWS As Worksheet, LastRow As Long, Irow As Long On Error Resume Next Set crWS = Sheets("total") On Error GoTo 0 If crWS Is Nothing Then MsgBox " غير موجودة total ورقة ", vbInformation Exit Sub Else Application.ScreenUpdating = False crWS.Range("A2:O" & crWS.Rows.Count).Clear End If Irow = 2 For Each WS In ThisWorkbook.Sheets If WS.Name <> crWS.Name Then LastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If LastRow >= 2 Then WS.Range("A2:O" & LastRow).Copy crWS.Cells(Irow, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme Irow = crWS.Cells(crWS.Rows.Count, 1).End(xlUp).Row + 1 End If End If Next WS Application.CutCopyMode = False Application.ScreenUpdating = True End Sub or Sub MergeTotal() Dim WS As Worksheet, Src As Worksheet Dim OnRng As Variant, rng As Range, r As Range Dim lastRow As Long, tmp As Long, col As Integer Set WS = Sheets("total") Application.ScreenUpdating = False lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row If lastRow > 1 Then: WS.Rows("2:" & lastRow).Clear tmp = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1 For Each Src In ThisWorkbook.Sheets If Src.Name <> WS.Name Then OnRng = Src.Range("A2:O" & Src.Cells(Src.Rows.Count, "A").End(xlUp).Row).Value WS.Cells(tmp, 1).Resize(UBound(OnRng, 1), UBound(OnRng, 2)).Value = OnRng For lastRow = 1 To Src.Cells(Src.Rows.Count, "A").End(xlUp).Row WS.Rows(tmp + lastRow - 1).RowHeight = 18.5 Next lastRow tmp = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1 End If Next Src With WS.Range("A1:O" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row) .Borders.LineStyle = xlContinuous: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With Application.ScreenUpdating = True End Sub الرواتب.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بعد إذن الأستاد @عبدالله بشير عبدالله بما ان الكود الخاص به يعتمد على التنسيق إليك حل آخر باظهار رسالة تنبيه عند تجاوز الحد الاقصى للتكرارات بشرط التاريخ في عمود b [نفس الشهر ] واسم المهنة عمود d والحالة في عمود F طريقة الإدخال الكود_ المهنة _الحالة Private Sub Worksheet_Change(ByVal Target As Range) Dim lastRow As Long, Max As Integer, kay As Variant, xdate As Variant Max = 5 Application.EnableEvents = False lastRow = Cells(Rows.Count, 4).End(xlUp).Row If Not Intersect(Target, Me.Columns("B")) Is Nothing Then For Each cell In Target If cell.Value <> "" And IsEmpty(cell.Offset(0, 1).Value) Then cell.Offset(0, 1).Value = Date Else cell.Offset(0, 1).Value = "" End If Next cell End If If Not Intersect(Target, Me.Range("C5:F" & lastRow)) Is Nothing Then For Each cell In Target If cell.Column = 6 And cell.Value = "إجازة" Then kay = cell.Offset(0, -2).Value xdate = cell.Offset(0, -3).Value If IsEmpty(kay) Or IsEmpty(xdate) Then MsgBox "يجب إدخال كود الموظف", vbExclamation, "إنتبـــــاه" cell.ClearContents GoTo SupAPP End If If WorksheetFunction.CountIfs(Range("D5:D" & _ lastRow), kay, Range("F5:F" & lastRow), "إجازة", Range("C5:C" & lastRow), xdate) > 1 Then cell.ClearContents MsgBox " تم الوصول للحد الأقصى للإجازات هدا الشهر لسائقين :" & _ " " & kay, vbExclamation, "إنتبـــــاه" GoTo SupAPP End If If WorksheetFunction.CountIfs(Range("D5:D" & _ lastRow), kay, Range("F5:F" & lastRow), "إجازة", Range("C5:C" & lastRow), ">=" & WorksheetFunction.EoMonth(xdate, -1) + 1, _ Range("C5:C" & lastRow), "<=" & WorksheetFunction.EoMonth(xdate, 0)) > Max Then cell.ClearContents MsgBox "وصلت للحد الأقصى لهذا الشهر في إجازات السائق: " & kay, vbExclamation, "إنتبـــــاه" End If End If SupAPP: Next cell End If Application.EnableEvents = True End Sub اجاز V1.xlsb

هذا كلام الذكاء الاصطناعي ... ولم اجربه نعم، يمكن استخدام VBA (Visual Basic for Applications) في Access لإنشاء QR Code يحتوي على بيانات صورة مشفرة (مثل صيغة Base64). ومع ذلك، لأن VBA لا يحتوي على مكتبة مدمجة لتوليد QR Codes، ستحتاج إلى مكتبة خارجية لتوليد الأكواد مثل zxing أو QR Code ActiveX Control. خطوات إنشاء QR Code باستخدام VBA: 1. تحويل الصورة إلى Base64 باستخدام VBA: يمكنك تحويل الصورة إلى نص Base64 داخل VBA باستخدام مكتبة مثل Microsoft XML 6.0. Function ConvertImageToBase64(filePath As String) As String Dim objStream As Object Dim objEncoder As Object ' فتح الصورة كـ Binary Set objStream = CreateObject("ADODB.Stream") objStream.Type = 1 ' Binary objStream.Open objStream.LoadFromFile filePath ' تحويل الصورة إلى Base64 Set objEncoder = CreateObject("MSXml2.DOMDocument").createElement("b64") objEncoder.DataType = "bin.base64" objEncoder.NodeTypedValue = objStream.Read ConvertImageToBase64 = objEncoder.Text ' تنظيف الكائنات objStream.Close Set objStream = Nothing Set objEncoder = Nothing End Function 2. إنشاء QR Code باستخدام مكتبة خارجية: يمكنك استخدام مكتبة QR Code جاهزة مثل QR Code ActiveX Control أو zxing. أضف المكتبة إلى مشروع Access الخاص بك. مثال لإنشاء QR Code Sub GenerateQRCode(base64Data As String, outputPath As String) Dim qrControl As Object ' إنشاء كائن QR Code من المكتبة الخارجية Set qrControl = CreateObject("YourQRCodeLibrary.QRCode") ' إدخال بيانات الصورة بصيغة Base64 qrControl.Text = base64Data ' حفظ الكود كصورة qrControl.SaveAsImage outputPath ' تنظيف الكائنات Set qrControl = Nothing End Sub 3. دمج الخطوات: قم بقراءة الصورة وتحويلها إلى Base64 باستخدام ConvertImageToBase64. استخدم النص المشفر لتوليد QR Code باستخدام GenerateQRCode. ملاحظات: تأكد من تثبيت المكتبة اللازمة لتوليد QR Code. حجم البيانات المشفرة (Base64) يمكن أن يكون كبيرًا، مما يجعل QR Code أكثر تعقيدًا. يُفضل تقليل حجم الصور المضغوطة قبل البدء.

وعليكم السلام ورحمة الله وبركاته يمكن ينفع جرب النموذج في قاعدة موجودة عندك حتى ترى المعيار يتحرك حجم القاعدة.accdb

Sub test() Dim wsSource As Worksheet, wsPass As Worksheet Dim lastRow As Long, i As Long, passRow As Long Set wsSource = Sheets("Sheet1") Set wsPass = Sheets("Sheet2") Application.ScreenUpdating = False Irow = wsPass.Cells(wsPass.Rows.Count, "G").End(xlUp).Row For j = 4 To Irow Step 2 wsPass.Range("A" & j & ":N" & j).ClearContents Next j lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row passRow = 4 For i = 3 To lastRow If InStr(1, LCase(wsSource.Cells(i, "G").Value), "1/6") > 0 Then wsPass.Cells(passRow, 1).Resize(1, 14).Value = wsSource.Cells(i, 1).Resize(1, 14).Value wsPass.Cells(passRow, 1).Value = passRow - 3 wsPass.Cells(passRow, 1).NumberFormat = wsSource.Cells(i, 1).NumberFormat passRow = passRow + 2 End If Next i Application.ScreenUpdating = True End Sub test.xlsb

وعليكم السلام ورحمة الله وبركانه قم بفتح ملف احياء وشغل الكود ولا تفتح الملف الرئيسي الكود يقوم بفتحه واغلاقه اثناء تنفيذ الكود نفس الكود يطبق على الادارات الاخرى عند حفظ الملف احقظه xslb او xlsm لان الملف به كود مراعاة اسماء الصفحات موحدة بمعنى في الملف الرئيسي احياء يكون في ملف احياء اسم الشيت نفس الاسم الملف الرئيسي.xlsb احياء.xlsb

حسب طلبك بدون شاشات حوارية وغبرها يجب كنابة اسم الملف في الكود يالملف الاول وان يكون الملفان في نقس المسار جرب واعلمنى ان كان هنلك اي تعديل طبعا الملف 2 لا يوجد به تعديل الملف1.xlsb

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

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Const Main As String = "الرئيسية " Sub destination(WSname As String) Dim WS As Worksheet, f As Worksheet, srcWS As Worksheet Set srcWS = Sheets(Main) Application.ScreenUpdating = False For Each WS In ThisWorkbook.Worksheets If WS.Name = WSname Then Set f = WS Exit For End If Next WS On Error Resume Next For Each WS In ThisWorkbook.Worksheets If WS.Name <> WSname Then WS.Visible = xlSheetVeryHidden Next WS On Error GoTo 0 f.Visible = xlSheetVisible: f.Activate If srcWS.Visible = xlSheetVisible And WSname <> Main Then srcWS.Visible = xlSheetVeryHidden Application.ScreenUpdating = True End Sub Sub GoToMainSheet() Sheets(Main).Visible = xlSheetVisible destination Main End Sub Sub GoToPage1() destination "كشف التلامي الحاضرين صفحة 1" End Sub Sub GoToPage2() destination "كشف التلامي الحاضرين صفحة 2" End Sub Sub GoToPage3() destination "الدخول و الخروج خلال الشهر" End Sub Sub GoToPage4() destination "المعلومات العامة" End Sub وفي حدث ThisWorkbook Private Sub Workbook_Open() Dim WS As Worksheet Const srcWS As String = "الرئيسية " For Each WS In ThisWorkbook.Worksheets WS.Visible = IIf(WS.Name = srcWS, xlSheetVisible, xlSheetHidden) Next WS End Sub كشف التلاميذ الحاضرين 2023--2024.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك إختيار ما يناسبك Sub CopyRowsmaktab() Dim LR As Long, I As Long, X As Long LR = Sheets("Main").Cells(Rows.Count, "B").End(xlUp).Row X = 6 Application.ScreenUpdating = False Sheets("دريم").Range("B6:G" & Sheets("دريم").Rows.Count).ClearContents For I = 6 To LR If Sheets("Main").Cells(I, "B").Value = "دريم" Then Sheets("دريم").Range("B" & X & ":G" & X).Value = Sheets("Main").Range("B" & I & ":G" & I).Value X = X + 1 End If Next I Application.ScreenUpdating = True End Sub او Sub CopyRowsToDream() Dim WS As Worksheet, dest As Worksheet Dim LastRow As Long, n As Long, X As Long Dim WSRng As Range, destRng As Range, Criteria As String Set WS = Sheets("Main") Set dest = Sheets("دريم") Criteria = "دريم" LastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row X = 6 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual dest.Range("B6:G" & dest.Rows.Count).ClearContents For n = 6 To LastRow If WS.Cells(n, "B").Value = Criteria Then Set WSRng = WS.Range(WS.Cells(n, "B"), WS.Cells(n, "G")) Set destRng = dest.Range(dest.Cells(X, "B"), dest.Cells(X, "G")) destRng.Value = WSRng.Value X = X + 1 End If Next n Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub او Sub CopiesToDream() Dim WS As Worksheet, dest As Worksheet Dim LastRow As Long, n As Long, X As Long Dim Ky As Boolean, WSRng As Range, destRng As Range Set WS = Sheets("Main") Set dest = Sheets("دريم") LastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row X = 6 Ky = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For n = 6 To LastRow If WS.Cells(n, "B").Value = "دريم" Then Ky = True Exit For End If Next n If Not Ky Then MsgBox "لا يوجد بيانات مطابقة للنسخ", vbExclamation Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Exit Sub End If dest.Range("B6:G" & dest.Rows.Count).ClearContents For n = 6 To LastRow If WS.Cells(n, "B").Value = "دريم" Then Set WSRng = WS.Range(WS.Cells(n, "B"), WS.Cells(n, "G")) Set destRng = dest.Range(dest.Cells(X, "B"), dest.Cells(X, "G")) destRng.Value = WSRng.Value X = X + 1 End If Next n Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "تم نسخ البيانات بنجاح", vbInformation End Sub

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Sub Worksheet_Change(ByVal Target As Range) Dim srcWS As Worksheet, début As Long, Fin As Long Dim a As Variant, b As Variant, i As Long Set srcWS = Me a = srcWS.[B3].Value b = srcWS.[C3].Value If Not Intersect(Target, srcWS.Range("B3:C3")) Is Nothing Then If a = "" Or b = "" Then Exit Sub If IsNumeric(a) And IsNumeric(b) Then début = a Fin = b If début <= Fin Then srcWS.Range("F7:F" & srcWS.Rows.Count).ClearContents For i = début To Fin srcWS.Cells(6 + i - début + 1, "F").Value = i Next i Else MsgBox _ " بداية الترقيم يجب أن تكون أصغر أو تساوي نهاية الترقيم", vbExclamation, "خطأ في الإدخال" End If End If End If End Sub بالمعادلات =IF(ROW(F7)-ROW($F$7)+$B$3<=$C$3, ROW(F7)-ROW($F$7)+$B$3, "") ترقيم.xlsb

وعليكم السلام ورحمة الله وبركاته الكود Sub DistributeStudents() Dim ws As Worksheet Dim lastRow As Long Dim dataRange As Variant Dim outputRange As Variant Dim rowNum As Long, colNum As Long Dim colStart As Integer, colEnd As Integer Dim totalStudents As Long, committees As Long Dim studentsPerCommittee As Long, extraStudents As Long Dim failedRows As String Const MaxStudentsPerCommittee As Long = 29 Set ws = ThisWorkbook.Sheets("ورقة1") lastRow = ws.Cells(ws.Rows.Count, 9).End(xlUp).row colStart = 11 colEnd = 30 ' Clear the output range ws.Range(ws.Cells(2, colStart), ws.Cells(lastRow, colEnd)).ClearContents ws.Range("I2:I" & lastRow).Interior.Color = xlNone ' إزالة أي ألوان سابقة dataRange = ws.Range("I2:J" & lastRow).Value ReDim outputRange(1 To UBound(dataRange, 1), colStart To colEnd) failedRows = "" For rowNum = 1 To UBound(dataRange, 1) totalStudents = dataRange(rowNum, 1) committees = dataRange(rowNum, 2) If committees > (colEnd - colStart + 1) Then MsgBox "عدد اللجان في الصف " & rowNum + 1 & " يتجاوز الحد الأقصى للأعمدة المتاحة!", vbExclamation Exit Sub End If If totalStudents = 0 Or committees = 0 Then For colNum = colStart To colEnd outputRange(rowNum, colNum) = "" Next colNum Else If totalStudents > committees * MaxStudentsPerCommittee Then ws.Cells(rowNum + 1, 9).Interior.Color = RGB(255, 0, 0) For colNum = colStart To colEnd outputRange(rowNum, colNum) = "" Next colNum failedRows = failedRows & (rowNum + 1) & ", " Else studentsPerCommittee = totalStudents \ committees extraStudents = totalStudents Mod committees For colNum = colStart To colStart + committees - 1 If extraStudents > 0 Then outputRange(rowNum, colNum) = studentsPerCommittee + 1 extraStudents = extraStudents - 1 Else outputRange(rowNum, colNum) = studentsPerCommittee End If Next colNum For colNum = colStart + committees To colEnd outputRange(rowNum, colNum) = "" Next colNum End If End If Next rowNum ws.Range(ws.Cells(2, colStart), ws.Cells(lastRow, colEnd)).Value = outputRange If failedRows <> "" Then failedRows = Left(failedRows, Len(failedRows) - 2) ' إزالة الفاصلة الأخيرة MsgBox "تم توزيع الطلاب على اللجان بنجاح! ولكن لم يتم توزيع الطلاب في الصفوف التالية بسبب تجاوز الحد الأقصى لعدد الطلبة على عدداللجان: " & vbCrLf & failedRows, vbExclamation Else MsgBox "تم توزيع الطلاب على اللجان بنجاح!", vbInformation End If End Sub الملف التوزيع.xlsb

وعليكم السلام ورحمة الله وبركاته الكود يعمل تلقائيا عند الانتهاء من الكتابة في خلية والخروج منها New Microsoft Excel Worksheet (2).xlsb

السلام عليكم ورحمة الله تعالى وبركاته طبعا قد يقول البعض ان الموضوع اتهرس فى ميت فيلم عربى قبل كده لكن على كل حال تم تدارك الكثير من المشاكل ومعالجتها بشكل احترافى - اخفاء اطار لاكسس بالشكل الطبيعى والتقليدى لعرض النموذج كاملا - اخفاء اطار الاكسس وعمل شفافية للنموذج لاظهار صور png او حسب خيال المسخدم - تم ضبط كواد التوسيط للنماذج والتقارير باحترافية ويعمل التوسيط مع الخاصية Pop Up فى اى وضع كانت فى حالة عدم استخدام الاخفاء - تم حل مشكلة عدم ظهور التقاربر عند الاخفاء بتكبير التقرير تلقائيا عند استخدام كود الاخفاء - امكانبة التصغير للتطبيق بجوار الساعة ( System Try ) - عند التصغير بجوار الساعة ممكن الضغط كليك يمين على الايقونة لتظهر قائمة اختيارات - تم ضبط كود تغير ايقونة الاكسس باحترافية وبشكل تلقائى من المسار المحدد او فى حالة عدم وجود الايقونة ترجع ايقونة الاكسس - تم التعامل مع الاكواد بحرفية تامة للعمل على بيئات الأنوية المختلفة سواء كانت 32 , 64 اترككم مع تجربة شيقة ملاحظة هامة : ارضاء للجميع ولاضفاء اكبر قدر ممكن من المرونة المرفق يحتوى على قاعدتان الاولى : تم تجميع كل الاكواد والدوال فى وحدة نمطية عامة واحدة وكلاس موديول واحد لسهولة الاستفادة منها ونقلهم الى اى قاعدة الثانية : فصل اكواد كل وظيفة على حدة فى مديول خاص بها تم اضافة تعديل وتحديث جديد بتاريخ 11/10/2024 رقم اصدار التعديل الاخيــر : 4.8 center and Hid and Tray Minimizer V 30.zip center and Hid and Tray Minimizer V 4.8.rar

وعليكم السلام ورحمة الله تعالى وبركاته ممكن توضح لنا ما المانع من إظافة عمود التسلسل يدويا وإعادة تعديل الكود بما يتناسب مع شكل البيانات ؟ اذا كان هذا يناسبك إليك الكود المعدل Sub DeleteRows() Dim WS As Worksheet, lastRow As Long, i As Long, OnRng As Range, response As VbMsgBoxResult Set WS = Sheets("ورقة1") lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row response = MsgBox("هل أنت متأكد أنك تريد حذف من استلمو الاول والثاني ؟", vbYesNo + vbQuestion, "تأكيد الحذف") If response = vbYes Then For i = lastRow To 3 Step -1 If WS.Cells(i, 3).Value <> "" And WS.Cells(i, 4).Value <> "" Then If OnRng Is Nothing Then Set OnRng = WS.Rows(i) Else Set OnRng = Union(OnRng, WS.Rows(i)) End If End If Next i If Not OnRng Is Nothing Then OnRng.Delete MsgBox OnRng.Count & " تم حذف الصفوف بنجاح", vbInformation, "عملية الحذف" Else MsgBox "لا توجد صفوف مطابقة للحذف", vbExclamation, "لم يتم الحذف" End If Else MsgBox "تم إلغاء عملية الحذف", vbInformation, "إلغاء" Exit Sub End If With WS.Range("A1:E50").Font .Name = "Arial": .Size = 16: .Bold = True: .Color = RGB(0, 0, 251) End With For i = 3 To WS.Cells(WS.Rows.Count, "B").End(xlUp).Row WS.Cells(i, 1).Value = i - 2 Next i With WS.PageSetup .TopMargin = .BottomMargin = .LeftMargin = .RightMargin = Application.InchesToPoints(0.5) End With WS.[C1].Value = Date - 1: WS.[C1].NumberFormat = "dd/mm/yyyy" WS.[B1].Value = Format(Date - 1, "dddd") Application.ScreenUpdating = True End Sub مثال1.xlsm

تفضل أخي تم تعديل الكود السابق وإظافة إمكانية تحديد الأعمدة المرحلة والمرحل إليها لتتمكن من تعديله بما يناسبك لاحقا Option Explicit Dim tmp As Variant Const tmpCol As String = "G" Private Sub Worksheet_Change(ByVal Target As Range) Dim arr(3) As Worksheet, OnRng As Range, Irow As Long, ling As Variant Set arr(0) = Sheets("بطاقة صنف"): Set arr(1) = Sheets("اضافة") Set arr(2) = Sheets("الصرف"): Set arr(3) = Sheets("الأصناف") If Not Intersect(Target, Me.Range("J2:I3")) Is Nothing Then SetApp False Set OnRng = arr(0).Range("B6:I" & arr(0).Rows.Count) OnRng.ClearContents Irow = arr(3).Cells(arr(3).Rows.Count, 1).End(xlUp).Row Me.Range("I3").Formula = "=IFERROR(VLOOKUP($J$2,'الأصناف'!$A$3:$B$" & Irow & ",2,0),"""")" Me.Range("I3").Value = Me.Range("I3").Value ling = Me.Range("I3").Value If Not IsEmpty(ling) And ling <> "" Then tmp = ling Call Cnt(arr(1), arr(0), ling, Array(4, 9, 10, 14, 16), Array(3, 5, 6, 4, 2)) Call Cnt(arr(2), arr(0), ling, Array(4, 19, 17, 9, 10, 11), Array(3, 2, 4, 7, 8, 9)) Else OnRng.ClearContents GoTo AppTrue End If AppTrue: SetApp True End If End Sub '"""""""""""""""""""""""""""""""""""" Private Sub Cnt(ByVal dest As Worksheet, ByVal tbl As Worksheet, _ ByVal temp As Variant, ByVal Colky As Variant, ByVal DestCols As Variant) Dim i As Long, x As Long, LastRow As Long, n As Long, Cel As Range, début As Long, fin As Long LastRow = dest.Cells(dest.Rows.Count, tmpCol).End(xlUp).Row début = 3 fin = LastRow For i = début To fin With dest If Not IsEmpty(.Cells(i, tmpCol).Value) And Not IsError(.Cells(i, tmpCol).Value) Then If .Cells(i, tmpCol).Value = temp Then x = WorksheetFunction.CountA(tbl.Range("B6:B1000")) For n = LBound(Colky) To UBound(Colky) Set Cel = tbl.Cells(6 + x, DestCols(n)) Cel.Value = .Cells(i, Colky(n)).Value Next n End If End If End With Next i End Sub '""""""""""""""""""""""""""""" Private Sub SetApp(ByVal Enable As Boolean) Application.ScreenUpdating = Enable Application.EnableEvents = Enable Application.Calculation = IIf(Enable, xlCalculationAutomatic, xlCalculationManual) End Sub مخازن 2024مكرو v3.xlsm

السلام عليكم ورحمه الله وبركاته اسعد الله اوقاتكم بكل خير تكمله لما سبق :-- عملية برمجة نظام إدارة الفواتير الضريبية: دراسة تفصيلية تم بحمدالله تصميم وتطوير نظام صغير لإدارة الفواتير الضريبية والإشعارات الخاصة بهيئة الزكاة والضريبة والجمارك، كان الهدف الأساسي هو بناء حل برمجي يلبي جميع متطلبات الهيئة، بما في ذلك تصدير الفواتير بتنسيق XML، التوقيع الرقمي، إنشاء رموز QR، وتصدير الفواتير بصيغة PDF. فيما يلي تفاصيل العمليات البرمجية التي تمت أثناء تطوير النظام: 1. إنشاء قاعدة بيانات شاملة باستخدام Microsoft Access تصميم الجداول: تم إنشاء جداول تحتوي على معلومات العملاء، المنتجات، تفاصيل الفواتير، والضرائب. تم تصميم هذه الجداول بطريقة مترابطة باستخدام المفاتيح الأساسية (Primary Keys) والمفاتيح الخارجية (Foreign Keys) لضمان التكامل بين البيانات. تصميم النماذج (Forms): استخدمت النماذج كواجهة للمستخدم لإدخال بيانات الفواتير بسهولة. تم إضافة ميزات التحقق من صحة البيانات (Validation Rules) للتأكد من إدخال البيانات بطريقة صحيحة ودقيقة. 2. تصدير الفواتير إلى صيغة XML التحليل الأولي لتنسيق XML المطلوب: تمت دراسة هيكلية الملفات المطلوبة من هيئة الزكاة والضريبة لتحديد جميع العناصر والمكونات مثل الرقم الضريبي، المبالغ، ونسب الضريبة. كتابة الأكواد لتوليد XML: باستخدام VBA (Visual Basic for Applications)، تمت كتابة الأكواد اللازمة لتحويل بيانات الفواتير المخزنة في قاعدة البيانات إلى ملف XML. تم استخدام مكتبة MSXML. 3. إضافة التوقيع الرقمي إلى الفواتير دمج شهادات التوقيع الرقمي: استخدمت مكتبة خارجية لدعم عملية التوقيع الإلكتروني. تضمنت العملية قراءة شهادة رقمية (Digital Certificate) وربطها بالبيانات المصدرة لضمان تأكيد صحة الفواتير وصلاحيتها. 4. إنشاء رموز QR للفواتير تحليل متطلبات QR Code: يحتوي رمز QR على بيانات مثل الرقم الضريبي، إجمالي الفاتورة، وتاريخ الإصدار. تم تشفير هذه البيانات باستخدام صيغة معتمدة من الهيئة. توليد QR Code برمجيًا: تم استخدام مكتبة خارجية لإنشاء رموز QR. تم تصميم الكود بحيث يتم توليد رمز QR وحفظه كصورة (Image) وربطه بملف الفاتورة. 5. تصدير الفاتورة إلى PDF إعداد التقارير (Reports): تم تصميم تقارير داخل Access لعرض الفواتير بشكل منظم واحترافي. تصدير التقرير إلى PDF: تم استخدام أمر DoCmd.OutputTo لتصدير التقرير بصيغة PDF. دمج رمز QR مع التقرير: تمت برمجة التقرير ليعرض رمز QR بشكل تلقائي داخل الملف المصدر. 6. معالجة الأخطاء وتحسين الأداء التعامل مع الأخطاء البرمجية: أثناء التطوير، ظهرت أخطاء تم كتابة أكواد لإدارة الأخطاء (Error Handling) والتأكد من تنفيذ الأوامر بسلاسة. تحسين الأداء: تم تحسين الأكواد لضمان تنفيذ العمليات بكفاءة، خاصة عند التعامل مع ملفات XML والفواتير الكبيرة. التحديات البرمجية توافق البيانات مع متطلبات الهيئة: كان من الضروري ضبط كل تفاصيل الفواتير لتطابق متطلبات هيئة الزكاة. تكامل العمليات: تنسيق العمليات المختلفة (XML، QR، PDF) وضمان عملها بانسجام شكل تحديًا تقنيًا، وتم تحقيقه بحمدالله النهاية النظام الناتج يعكس عملية برمجية متكاملة، تم فيها المزج بين التحليل الدقيق، كتابة الأكواد الفعالة، وحل التحديات بطريقة مبتكرة. ساهم هذا المشروع في بناء أداة عملية تلبي احتياجات الأعمال وتحقق الالتزام الكامل بلوائح الفوترة الإلكترونية. =========رابط الشرح جاري الرفع :- الملفات :- https://drive.google.com/file/d/1nhStXOT_w1OlTANO4KnI9l_asDIFcIE1/view?usp=drive_link ملحوظه:- الفديوهات هتكون طويله شويه بالتوفيق للجميع

اتفضل الشيت بالكود المستخدم لعله يكون الطلوب وعدل عليه حسب ما تريد Sub PrintSheetInChunks() Dim ws As Worksheet Dim LastRow As Long, LastCol As Long Dim RowStart As Long, RowEnd As Long Dim ColStart As Long, ColEnd As Long Dim PageNum As Long ' تحديد ورقة العمل الحالية Set ws = ThisWorkbook.Sheets("Sheet1") ' قم بتغيير اسم الورقة حسب الحاجة ' الحصول على آخر صف وآخر عمود في البيانات LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column ' تحديد عدد الصفوف والأعمدة لكل صفحة (25 صفًا و25 عمودًا) RowStart = 1 ColStart = 1 PageNum = 1 ' تحديد الصفوف والأعمدة للطباعة Do While RowStart <= LastRow RowEnd = RowStart + 24 ' 25 صفًا لكل صفحة (من RowStart إلى RowEnd) If RowEnd > LastRow Then RowEnd = LastRow ColEnd = ColStart + 24 ' 25 عمودًا لكل صفحة (من ColStart إلى ColEnd) If ColEnd > LastCol Then ColEnd = LastCol ' تحديد منطقة الطباعة ws.PageSetup.PrintArea = ws.Range(ws.Cells(RowStart, ColStart), ws.Cells(RowEnd, ColEnd)).Address ' إعدادات الطباعة With ws.PageSetup .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = False .PrintTitleRows = "" ' إذا أردت إضافة عناوين ثابتة في الأعلى يمكنك تعديل هذه .PrintTitleColumns = "" ' وإذا أردت إضافة أعمدة ثابتة يمكنك تعديل هذه End With ' طباعة الصفحة ws.PrintOut ' تحديث الصفوف والأعمدة للطباعة في الصفحة التالية RowStart = RowEnd + 1 If RowStart > LastRow Then Exit Do ' الخروج إذا تم الانتهاء من جميع الصفوف If ColEnd < LastCol Then ColStart = ColEnd + 1 Else ColStart = 1 End If PageNum = PageNum + 1 Loop End Sub مرتبات.xlsm

جرب هذا .... On Error Resume Next Dim s As String s = InputBox("ادخل الرقم القومي المكون من 14 رقم", "ابدا البحث من فضلك") If s <> "" Then ' تطبيق الفلتر Me.Filter = "IDNumber = '" & s & "'" Me.FilterOn = True Else MsgBox "الرجاء إدخال الرقم القومي.", vbExclamation, "خطأ" End If

وعليكم السلام ورحمة الله تعالى وبركاته جرب إحدى المعادلات التالية =IF(D5304<>"",COUNTIFS(D2:D5294, D5304),"") أو =IF(D5304<>"",COUNTIF($D$2:$D$5294, D5304), "") ولجلب Driver ID =IFERROR(INDEX($D$2:$D$5294, MATCH(0, IF(($D$2:$D$5294<>"")* ($D$2:$D$5294<>0), COUNTIF($D$5303:D5303, $D$2:$D$5294), ""), 0)), "") احصاء عدد الطلبات.rar

والسلام عليكم ورحمة الله وبركاته جرب الكود التالي لعله المطلوب Sub Print25RowsPerPage() Dim wsSource As Worksheet Dim rowCount As Long Dim rowsPerPage As Long Dim i As Long Dim printRange As Range Dim pageNum As Long ' تحديد ورقة العمل المصدر Set wsSource = ThisWorkbook.Sheets("ورقة1") ' تأكد من تغيير اسم الورقة إلى الورقة المناسبة rowCount = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row ' حساب عدد الصفوف rowsPerPage = 25 ' عدد الصفوف في كل ورقة pageNum = 1 ' لتتبع رقم الصفحة أثناء الطباعة ' التكرار عبر الصفوف وتقسيمها على أوراق الطباعة For i = 1 To rowCount Step rowsPerPage ' تحديد نطاق الطباعة (25 صفًا لكل ورقة) Set printRange = wsSource.Rows(i & ":" & WorksheetFunction.Min(i + rowsPerPage - 1, rowCount)) ' تعيين نطاق الطباعة wsSource.PageSetup.PrintArea = printRange.Address ' تعيين إعدادات الطباعة (اختياري: إذا كنت تريد تغيير إعدادات الطباعة) With wsSource.PageSetup .Orientation = xlPortrait ' وضع الصفحة عمودي (يمكنك تغييره إلى xlLandscape إذا أردت الوضع الأفقي) .FitToPagesWide = 1 ' تأكد من طباعة الصفحة على عرض واحد .FitToPagesTall = False ' لا تحدد عدد الصفوف على الصفحة .LeftHeader = "صفحة " & pageNum ' عنوان الصفحة End With ' طباعة النطاق المحدد wsSource.PrintOut ' تحديث رقم الصفحة pageNum = pageNum + 1 Next i

لا اعلم ما السبب حملت الملف ويعمل سارقع الملف مرة اخرى اخبرني بالنتيجة ازالة1.xlsm

نسخة مختصرة لعرض التقارير فقط بسيط والكود بسيط ودالة مبسطة 1- من خلال المكرو تفتح قائمة مخترة من فورم ولكن خليته فاضي 2- لا يحمل جدول اعدادة الا مقاس الشاشة وتقرير هل يوجد مقترح بتعديل على عرض التقرير او التصميم او طريقة افضل منها ☕ ====================================( Video ) show_report_withcontrol.rar

أنا متأكد ان الحلبي يسأل من اجل حماية نفسه .. وبياناته .. من باب العلم عن نفسي ومن باب التعلم حاولت مع امتداد mdb ونجحت ولم اقدر على accdb .. لذا اعتبرها اكثر أمانا

أخي @jo_2010 ، قمت بتعديل بسيط على ملفك ، وهو إضافة حقل جديد = PathPic في الجدول لتخزين المسار فيه بشكل صريح بدلاً من الطريقة التي يم فيها جلب مسار الملف لحذفه ، وأصبح الكود بعد تعديله في زر الحذف بالشكل التالي :- On Error GoTo HandleError Dim fileToDelete As String Dim response As VbMsgBoxResult Dim db As DAO.Database Dim sql As String Dim recordID As String Dim subFolderPath As String recordID = [Forms]![frm_sader_wared]![Pname].Value subFolderPath = CurrentProject.Path & "\AttachedFiles\" & recordID fileToDelete = Me.PathPic.Value If Not IsNull(fileToDelete) And Dir(fileToDelete) <> "" Then response = MsgBox("هل تريد حقاً حذف هذا الملف؟", vbYesNo + vbQuestion, "تأكيد الحذف") If response = vbYes Then Kill fileToDelete Set db = CurrentDb() sql = "DELETE FROM TblAttchedFiles WHERE id=" & Me.ID db.Execute sql, dbFailOnError On Error Resume Next RmDir subFolderPath On Error GoTo HandleError Me.Requery End If Else MsgBox "لا يوجد شئ لحذفه", vbExclamation, "خطأ" End If HandleExit: Exit Sub HandleError: Select Case Err.Number Case 94 MsgBox "لا يوجد شئ لحذفه", vbExclamation, "خطأ" Case Else MsgBox "خطأ رقم: " & Err.Number & vbNewLine & Err.Description, vbCritical, "خطأ" End Select Resume HandleExit وهذا ملفك بعد التعديل base_s_w.accdb

اخي @أبوالباسل دالة VLOOKUP لديها قاعدة أساسية يجب الإنتباه إليها فهي تعمل فقط من اليسار إلى اليمين بمعنى تبحث دائما في العمود الأول من النطاق المحدد وهو في حالتك العمود G لكنك تريد البحث عن رقم سير باستخدام العمود H (الذي يحتوي على أسماء العملاء) وهذا يخالف طريقة عمل VLOOKUP لأن العمود H ليس العمود الأول بإختصار دالة VLOOKUP لا يمكنها البحث في عمود ليس هو الأول ضمن نطاق البيانات لهدا حاولنا إستخدام بدائل أخرى مثل INDEX و MATCH هذه الدوال لا تعتمد على ترتيب الأعمدة للتوضيح أكثر حاول عكس ترتيب الأعمدة بجعل عمود أسماء العملاء على اليمين وجعل عمود سير يسارا ووضع المعادلة الخاصة بك على الشكل التالي =IF(C3<>"", IFERROR(VLOOKUP(C3, $G$3:$H$121, 2, 0), "غير موجود"), "") كما تلاحظ VLOOKUP الآن تبحث في العمود H (أسماء العملاء) لأنه أصبح العمود الأول و تسترجع القيمة المقابلة من العمود G (سير ) بنجاح خط السير-VLOOKUP.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته جرب إستخدام إحدى الصيغ التالية =IFERROR(INDEX($G$3:$G$121, MATCH(C3, $H$3:$H$121, 0)), "غير موجود") 'أو =XLOOKUP(C3, $H$3:$H$121, $G$3:$G$121, "غير موجود") بالأكواد Option Explicit Sub UpdateOrder() Dim WS As Worksheet, lastRow As Long, i As Long Dim Client As String, tmp As Variant Set WS = Sheets("خط السير") lastRow = 120 Application.ScreenUpdating = False WS.Range("b3:b" & lastRow).ClearContents For i = 3 To lastRow Client = WS.Cells(i, "C").Value If Client <> "" Then tmp = Application.Match(Client, WS.Range("H3:H" & lastRow), 0) If Not IsError(tmp) Then WS.Cells(i, "B").Value = WS.Cells(tmp + 2, "G").Value Else WS.Cells(i, "B").Value = "غير موجود" End If End If Next i Application.ScreenUpdating = True End Sub خط السير.rar

السلام عليكم الملف حجمه يتجاوز 11 مبقا بسبب التنسيق الشرطى للصفوف التسعة للعمود g من بداية العمود الى اخر العمود يعنى 9مليون خلية بها تنسيق شرطى ارجو تحديد المطلوب للملف كما اخبرك استاذنا الفاضل حسونة حسبن ساساهم بخاصية البحث عن طالب واظافة حالة الطالب من السداد وعدم السداد واحضار اجمالى الرسوم الى صفحة main وان هناك شئ نريد تعديله في الملف ارجو تحديده ملف المدرسة كامل الفصول 2024-2023.zip

وعليكم السلام ورحمة الله تعالى وبركاته بطريقة أخرى Sub TaxCivil() Dim Irow&, lastRow&, lastCol&, i&, j&, k&, WS As Worksheet, dest As Worksheet, tmp As Double, _ OnRng As Variant, r As Variant, headers As Variant, n As Double, civil As String Set WS = Sheets("المعلومات") Set dest = Sheets("الموظفين") Application.ScreenUpdating = False Irow = dest.Cells(dest.Rows.Count, 3).End(xlUp).Row lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row lastCol = WS.Cells(2, WS.Columns.Count).End(xlToLeft).Column OnRng = dest.Range("A2:E" & Irow).Value r = WS.Range(WS.Cells(3, 1), WS.Cells(lastRow, lastCol)).Value headers = WS.Range(WS.Cells(2, 3), WS.Cells(2, lastCol)).Value dest.Range("E2:E" & Irow).ClearContents For i = 1 To UBound(OnRng, 1) n = OnRng(i, 3): civil = OnRng(i, 4) tmp = 0 If n = 0 Or Trim(civil) = "" Then GoTo SkipRow For j = 1 To UBound(r, 1) If n >= r(j, 1) And n <= r(j, 2) Then For k = 1 To UBound(headers, 2) If headers(1, k) = civil Then tmp = r(j, k + 2) Exit For End If Next k Exit For End If Next j OnRng(i, 5) = IIf(tmp > 0, tmp, "غير محدد") SkipRow: Next i dest.Range("A2").Resize(UBound(OnRng, 1), 5).Value = OnRng Application.ScreenUpdating = True End Sub ضريبة.xlsb

السلام عليكم الكود Sub CalculateTax() Dim wsInfo As Worksheet Dim wsEmployees As Worksheet Dim lastRow As Long Dim i As Long Dim j As Integer Dim salary As Double Dim status As String Dim tax As Double Dim minSalary As Double Dim maxSalary As Double Dim found As Boolean Set wsInfo = ThisWorkbook.Sheets("المعلومات") Set wsEmployees = ThisWorkbook.Sheets("الموظفين") lastRow = wsEmployees.Cells(wsEmployees.Rows.Count, 2).End(xlUp).Row For i = 2 To lastRow salary = wsEmployees.Cells(i, 3).Value status = wsEmployees.Cells(i, 4).Value found = False For j = 3 To 6 minSalary = wsInfo.Cells(j, 1).Value maxSalary = wsInfo.Cells(j, 2).Value If salary >= minSalary And salary <= maxSalary Then For Each cell In wsInfo.Range("C2:L2") If cell.Value = status Then tax = wsInfo.Cells(j, cell.Column).Value wsEmployees.Cells(i, 5).Value = tax found = True Exit For End If Next cell If found Then Exit For End If Next j If Not found Then wsEmployees.Cells(i, 5).Value = "" End If Next i MsgBox "تم حساب الضريبة بنجاح!", vbInformation End Sub الملف ضريبة.xlsb

السيد Khorsheed Omar المعادلة =IF([@[الاسم الثلاثي]]<>""; VLOOKUP([@[الاسم الثلاثي]]; 'البيانات الأساسية'!$A$2:$R$100;MATCH("2.2025"; 'البيانات الأساسية'!$1:$1; 0); FALSE); "") 1رواتب.xlsm