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

اعمل استعلام وضع فيه هذا مع تعديل اسم الحق الذي به المبلغ واسم الجدول لديك SELECT Amount, IIf([Amount] <= 15000, [Amount] * 0.1, 15000 * 0.1) AS [10%], IIf([Amount] > 15000, ([Amount] - 15000) * 0.15, 0) AS [15%] FROM YourTableName;

السلام عليكم جرب الكود Sub تلوين_المكرر() Dim ws As Worksheet, rng As Range, cell As Range Dim dict As Object, lastRow As Long Dim r As Long, c As Long, key As String Set ws = ActiveSheet lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row If lastRow < 5 Then lastRow = 5 Set rng = ws.Range("A5:J" & lastRow) rng.Interior.ColorIndex = xlNone Application.ScreenUpdating = False For r = 5 To lastRow For c = 1 To 10 Set cell = ws.Cells(r, c) If Not IsError(cell.Value) And Len(cell.Value) > 0 Then key = Trim(cell.Value) Set dict = CreateObject("Scripting.Dictionary") For Each c2 In ws.Range(ws.Cells(r, 1), ws.Cells(r, 10)) If c2.Value = key Then dict(key) = dict(key) + 1 Next If dict(key) > 1 Then cell.Interior.Color = vbRed: GoTo NextCell ' التحقق عموديًا dict.RemoveAll For Each r2 In ws.Range(ws.Cells(5, c), ws.Cells(lastRow, c)) If r2.Value = key Then dict(key) = dict(key) + 1 Next If dict(key) > 1 Then cell.Interior.Color = vbRed End If NextCell: Next c Next r Application.ScreenUpdating = True End Sub

شوف الافكار هنا بها تحقيق طلبك تماما وبدون تخزين محافظة الميلاد ولا تاريخ الميلاد ولا السن حتى داخل الجدول Test.accdb

وعليكم السلام ورحمة الله وبركاته جرب الكود حيث قبل التنفيذ، يقوم بحذف أي دوائر سابقة 1الثالث.xlsb