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

بارك الله فيك .... هناك عبارات محجوزة لاكسس ولا تستخدمها في التسمية للعناصر او الحقول ابدااااااااااااااااااااااااااااا انظر ......

راجع هذا الموضوع للكلمات المحجوزة للاكسس

قد يكون مفتاح الشيفت محمي ، اذا قاعدة البيانات بصيغة Accde أو Mde فلاااااااا تتعب نفسك في البحث عن حل أما إذا كانت قاعدة البيانات بصيغة Accdb أو Mdb فهناك عدة طرق . منها إنشاء قاعدة بيانات جديدة واستيراد المكونات لها ، وإذا طلب منك كلمة مرور لقاعدة البيانات فاكتب الباسوورد الذي تملكه. غير ذلك.......... ليس لي دخل 😅

الكود بضاف في حدث الورقة بدون زر وبوجد ملفك وبه الكود فى المشاركة السابقة حمل الملف واذا كان الماكرو غير مفعل فقم بتفعيله تمكبن المحتوى بعد فتح الملف اكتب فى العمو دC كلمة البحث فقط تاتى لك بالنسبة% الملف مرة اخرى وشغال 100% بحث بجزء من الجمله1.xls

قمت بعمل مثال لك بفصل الحالات الثلاتة كما طلبت الكود Sub FilterValues() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("Sheet1") Dim lastRow As Long lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row ws.Range("G2:H" & ws.Cells(ws.Rows.Count, "G").End(xlUp).Row).ClearContents ws.Range("I2:J" & ws.Cells(ws.Rows.Count, "I").End(xlUp).Row).ClearContents ws.Range("K2:L" & ws.Cells(ws.Rows.Count, "K").End(xlUp).Row).ClearContents Dim negArr() As Variant Dim posArr() As Variant Dim zeroArr() As Variant Dim i As Long, negCount As Long, posCount As Long, zeroCount As Long Dim dataRange As Range Set dataRange = ws.Range("B2:C" & lastRow) Dim dataArr As Variant dataArr = dataRange.Value ReDim negArr(1 To UBound(dataArr, 1), 1 To 2) ReDim posArr(1 To UBound(dataArr, 1), 1 To 2) ReDim zeroArr(1 To UBound(dataArr, 1), 1 To 2) negCount = 0 posCount = 0 zeroCount = 0 For i = 1 To UBound(dataArr, 1) Select Case dataArr(i, 2) Case Is < 0 negCount = negCount + 1 negArr(negCount, 1) = dataArr(i, 1) negArr(negCount, 2) = dataArr(i, 2) Case Is > 0 posCount = posCount + 1 posArr(posCount, 1) = dataArr(i, 1) posArr(posCount, 2) = dataArr(i, 2) Case Else zeroCount = zeroCount + 1 zeroArr(zeroCount, 1) = dataArr(i, 1) zeroArr(zeroCount, 2) = dataArr(i, 2) End Select Next i ws.Range("G2").Resize(negCount, 2).Value = Application.Index(negArr, Evaluate("ROW(1:" & negCount & ")"), Array(1, 2)) ws.Range("I2").Resize(posCount, 2).Value = Application.Index(posArr, Evaluate("ROW(1:" & posCount & ")"), Array(1, 2)) ws.Range("K2").Resize(zeroCount, 2).Value = Application.Index(zeroArr, Evaluate("ROW(1:" & zeroCount & ")"), Array(1, 2)) End Sub الملف فصل الدائن والمدين والصفرية الى اعمدة جديدة.xlsb

لا لا ...اسم الحقل receiveddate ليس فيه مشكلة بل اسم مربع النص الموجود قي النموذج .... انظر ...

السبب استخدام حقل من نوع رقم كبير "عند إضافة حقل "رقم كبير" إلى جدول وحفظ تصميم الجدول، فإنك بذلك تقوم بتمكين نوع البيانات "رقم كبير" بفعّالية، ولم تعد قاعدة البيانات متوافقة مع الإصدارات السابقة من Access ستحتاج إلى Access 2016 (‏16.0.7812 أو الإصدار الأحدث)." الملف مرفق بعد تعديل نوع الحقل الى نوع رقم Delete Col(1).accdb

هو دا بارك الله فيك

شكرا استاذ : ابو البشر شكرا استاذ : Foksh تم انشاء قاعدة جديدة واستيراد مكوناتها لها .. كما تفضلت

عليكم السلام انت بحاجة لعمل استعلام تجميعي لللإسم فقط بحيث تظهر الاسماء بدون تكرار .. ثم تعمل بها جدول وتعمل في الجدول ترقيم تلقائي الآن لديك جدولا جديدا بالاسماء غير مكررة مرقمة الآن كيف تنقل هذه الأرقام الى الجدول الرئيسي ؟ تعمل استعلام تحديث تحدث به الرقم في الجدول الرئيس وتضع فيه معيارا : ( الرقم في الجدول الرئيسي= الرقم في الجدول الجديد ) المعيار : تطابق الأسماء في الجدولين ----------------------- على كل حال في مثل حالتك يتبين اهمية عمل جدول رأس وجدول فرعي للسجلات التي تتكرر العمليات فيها

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub Copier_tbl_Employe() Dim Code As String, lastrow As Long, n As Boolean Dim WS As Worksheet, dest As Worksheet Dim ColB As Variant, i As Long, tmp As Long Set WS = ThisWorkbook.Sheets("المصدر") Set dest = ThisWorkbook.Sheets("الهدف") tmp = 16: Code = dest.[B5].Value If Code = "" Then: MsgBox "الرجاء إدخال رقم الموظف", vbExclamation: Exit Sub lastrow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row ColB = WS.Range("B1:B" & lastrow).Value n = False For i = 1 To UBound(ColB) If ColB(i, 1) = Code Then n = True Exit For End If Next i Application.ScreenUpdating = False If n Then With dest.Range("A5:I20") .UnMerge .ClearContents End With WS.Range("A" & i & ":I" & i + tmp).Copy With dest.Range("A5") .PasteSpecial Paste:=xlPasteAll End With Else MsgBox "لم يتم العثور على رقم الموظف : " & Code, vbExclamation End If Application.CutCopyMode = False Application.ScreenUpdating = True End Sub جلب بيانات اعتمادا على رقم الموظف.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك ذالك بتعديل كود إفراغ البيانات السابقة بهذا الشكل فقط ليتجاهل إفراغ عمود M With Union(sh.Range("K6:L64"), sh.Range("P6:Q64")) .FormatConditions.Delete .ClearContents End With لتضمينها داخل الكود With sh .Range("M3").Formula = "=COUNTIF(M6:M37, ""حضور"") + COUNTIF(R6:R37, ""حضور"")" .Range("N3").Formula = "=COUNTIF(M6:M37, ""غياب"") + COUNTIF(R6:R37, ""غياب"")" .Range("P3").Formula = "=COUNTIF(M6:M37, ""اجازة"") + COUNTIF(R6:R37, ""اجازة"")" .Range("Q3").Formula = "=IF(SUM(N6:N37, S6:S37) = 0, """", SUM(N6:N37, S6:S37))" End With COUNTIF.xlsm

وعليكم السلام ورحمه الله وبركاته

بصراحة اخجلتني بكلامه هدا فأنت تقريبا بعمر والدي بارك الله لك في عمرك و عملك و صحتك و اتم عليك نعمته و رزقك سعادة الدارين أنت وأستادنا @عبدالله بشير عبدالله له خالص تقديري وامتناني على المجهود المتواصل لمساعدة الإخوة الأعضاء كما يسعدني ويشرفني ولي الفخر أني قد شاركت معكم حل هدا الموضوع ما قام به أستادنا عبد الله يوفي بالغرض 1) ما جعلني أقوم بتعديل الكود الخاص بي على حسب متطلباتك الجديدة هو أنني بعد تجربة الملف الدي زودنا به أستادنا لاحظت هفوات بسيطة بطريقة الحساب في حالة كان عدد الايام المستخرجة اكبر من 64 صف مثال لو قمنا بادخال تاريخ البداية 2024/10/22 تاريخ النهاية 2025/01/20 النتائج تظهر بشكل خاطئ وعند إنقاص يوم تصبح صحيحة 2) ضرورة إظافة شرط التحقق من التواريخ الصحيحة تفاديا للاخطاء خاصة انك ستقوم بإدخال التواريخ يدويا 3) تعريب أسماء الأيام جرب هدا Sub CreateDaysList() Dim startDate As Date, endDate As Date Dim xDate As Date, xCount As Long, cnt As Long, tmp As Long Dim sh As Worksheet: Set sh = Sheets("Sheet1") If IsEmpty(sh.[L2].Value) Or IsEmpty(sh.[N2].Value) Or Not IsDate(sh.[L2].Value) Or Not IsDate(sh.[N2].Value) Then MsgBox "يرجى إدخال تواريخ البداية والنهاية بشكل صحيح", vbExclamation Exit Sub End If startDate = sh.[L2].Value endDate = sh.[N2].Value If startDate > endDate Then MsgBox "تاريخ البداية يجب أن يكون أقل أو يساوي تاريخ النهاية", vbExclamation Exit Sub End If xDate = startDate cnt = 6 tmp = 0 xCount = 0 Application.ScreenUpdating = False With sh.Range("K6:N64") .FormatConditions.Delete .ClearContents End With Do While xDate <= endDate And xCount < 64 If Weekday(xDate, vbSunday) <> vbFriday And Weekday(xDate, vbSunday) <> vbSaturday Then sh.Cells(cnt, 11 + tmp).Value = Choose(Weekday(xDate, vbSunday), _ "الأحد", "الإثنين", "الثلاثاء", "الأربعاء", "الخميس") sh.Cells(cnt, 12 + tmp).Value = Format(xDate, "yyyy/mm/dd") cnt = cnt + 1 xCount = xCount + 1 If cnt > 37 Then tmp = 2 cnt = 6 End If End If xDate = xDate + 1 Loop Call crc(sh.Range("K6:K37"), "=K6=""الأحد""", RGB(255, 255, 0)) Call crc(sh.Range("M6:M37"), "=M6=""الأحد""", RGB(255, 255, 0)) Application.ScreenUpdating = True End Sub Sub crc(rng As Range, condition As String, color As Long) With rng.FormatConditions.Add(Type:=xlExpression, Formula1:=condition) .Interior.color = color End With End Sub ادراج أيام الشهر كاملا V4 .xlsm وفي حدث ورقة 1 Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim sh As Worksheet: Set sh = Me If Not Intersect(Target, sh.Range("L2:N2")) Is Nothing Then Call CreateDaysList End If End Sub

ما شاء الله استاذ محمد معادلة وكود . اثراء للموضوع المعادلة التالية تؤدى الى نفس النتيجة وهى تستخدم دالة AGGREGATE لتحديد آخر عمود يحتوي على قيمة غير فارغة، ومن ثم دالة INDEX لاسترجاع القيمة المطابقة. المعاداة =IFERROR( IF(A14=""; ""; INDEX($B$2:$E$9; MATCH(A14; $A$2:$A$9; 0); AGGREGATE(14; 6; COLUMN($B$2:$E$2) / (INDEX($B$2:$E$9; MATCH(A14; $A$2:$A$9; 0); 0)<>""); 1) - COLUMN($B$2) + 1) ); "بدون نتيجة") الملف اخر ادخال بالصف.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا =IFERROR(IF(A14="","",LOOKUP(2,1/(INDEX($B$2:$E$9,MATCH(A14,$A$2:$A$9,0),0)<>""),INDEX($B$2:$E$9,MATCH(A14,$A$2:$A$9,0),0))),"بدون نتيجة") أو بإستخدام vba Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim Code As Variant, dataA As Variant, dataB As Variant Dim rngA As Range, rngB As Range, rngC As Range Dim tmp As Variant, result As String Dim cell As Range, col As Long Dim msg As String: msg = "بدون نتيجة" Set rngA = Me.Range("A2:A9") Set rngB = Me.Range("B2:E9") Set rngC = Me.Range("A14:A21") Application.ScreenUpdating = False Application.EnableEvents = False On Error GoTo CleanExit If Not Intersect(Target, Union(rngB, rngC)) Is Nothing Then dataA = rngA.Value dataB = rngB.Value For Each cell In rngC If Trim(cell.Value) <> "" Then tmp = Application.Match(cell.Value, rngA, 0) If Not IsError(tmp) Then result = msg For col = 4 To 1 Step -1 If Trim(dataB(tmp, col)) <> "" Then result = dataB(tmp, col) Exit For End If Next col cell.Offset(0, 1).Value = result Else Code = cell.Value cell.Resize(1, 2).ClearContents MsgBox "الكود " & Code & " غير موجود", vbExclamation End If Else cell.Offset(0, 1).ClearContents End If Next cell End If CleanExit: Application.EnableEvents = True Application.ScreenUpdating = True End Sub ppp.xlsb