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

جرب وضع هدا في Module Option Explicit Sub TestUpdate() Dim dest As Worksheet, WS As Worksheet Dim Clé As String, i As Integer Dim tmp As Range, cnt As Variant Dim Irow As Long, ColArr As Variant, rng As Range Set WS = Sheets("استدعاء") Set dest = Sheets("السجل") Clé = WS.Range("B8").Value If Clé = "" Then Exit Sub Set rng = dest.Range("B2:B" & dest.Cells(dest.Rows.Count, 2).End(xlUp).Row) Set tmp = rng.Find(Clé, LookIn:=xlValues, lookat:=xlWhole) If tmp Is Nothing Then MsgBox "لم يتم العثور على الإسم في السجل", vbExclamation Exit Sub End If Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Irow = tmp.Row ColArr = Array(8, 9, 10, 14, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29) cnt = Array(WS.Range("A12").Value, WS.Range("B12").Value, WS.Range("C12").Value, _ WS.Range("D12").Value, WS.Range("E12").Value, WS.Range("F12").Value, _ WS.Range("G12").Value, WS.Range("H12").Value, WS.Range("A15").Value, _ WS.Range("B15").Value, WS.Range("C15").Value, WS.Range("D15").Value, _ WS.Range("E15").Value, WS.Range("F15").Value, WS.Range("G15").Value, WS.Range("H15").Value) For i = LBound(ColArr) To UBound(ColArr) If dest.Cells(Irow, ColArr(i)).Value <> cnt(i) Then dest.Cells(Irow, ColArr(i)).Value = cnt(i) End If Next i Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub وفي حدث ورقة استدعاء Private Sub Worksheet_Change(ByVal Target As Range) Dim Clé As String, cntArr As Range Set cntArr = Me.Range("A12:H12,A15:B15") If Not Intersect(Target, cntArr) Is Nothing Then Call TestUpdate End If End Sub اذا حصل تغيير - يذهب التغيير الى السجل على اساس الأسم.xlsm

وعليكم السلام ورحمة الله وبركاته 🙂 أنشيء هذا الاستعلام : وهذا الناتج : وبعدها صمم تقرير مبني على هذا الاستعلام .. 🙂 احصاء بالعدد والمبلغ.rar

العفو أخي يسعدنا أننا إستطعنا مساعدتك إليك طريقة أسرع ومختصرة Option Explicit Sub test2() Dim lastrow&, a&, i&, n&, cnt& Dim f As Worksheet, WS As Worksheet, OnRng As Variant Set WS = Sheets("الخزينه") Set f = Sheets("تحصيلات نقدية") lastrow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row a = f.Cells(f.Rows.Count, "A").End(xlUp).Row + 1 OnRng = WS.Range("B4:G" & lastrow).Value For i = 1 To UBound(OnRng, 1) cnt = Application.WorksheetFunction.CountIfs(f.Range("A2:A" & a - 1), OnRng(i, 1), _ f.Range("B2:B" & a - 1), OnRng(i, 6), _ f.Range("C2:C" & a - 1), OnRng(i, 2), _ f.Range("D2:D" & a - 1), OnRng(i, 5)) If cnt = 0 And (OnRng(i, 6) = "دفعه" Or OnRng(i, 6) = "تصفيه") Then f.Cells(a, 1).Resize(1, 4).Value = Array(OnRng(i, 1), OnRng(i, 6), OnRng(i, 2), OnRng(i, 5)) a = a + 1 n = n + 1 End If Next i MsgBox IIf(n > 0, "تم ترحيل البيانات بنجاح", "البيانات محدثة مسبقا") End Sub مشروع خزنه 1.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Option Explicit Sub test() Dim LR As Long, i As Long, c As Long, R As Long Dim D As String, T As String, n As Long Dim Sh As Worksheet, WS As Worksheet Set Sh = Sheets("تحصيلات نقدية") LR = Range("b" & Rows.Count).End(xlUp).Row R = Sh.Range("a" & Rows.Count).End(xlUp).Row + 1 D = "دفعه" T = "تصفيه" For i = 4 To LR c = Application.WorksheetFunction.CountIfs(Sh.Range("a2:a" & R - 1), Range("b" & i), _ Sh.Range("b2:b" & R - 1), Range("g" & i), _ Sh.Range("c2:c" & R - 1), Range("c" & i), _ Sh.Range("d2:d" & R - 1), Range("f" & i)) If c = 0 And (Range("G" & i) = D Or Range("G" & i) = T) Then Sh.Range("a" & R).Value = Range("b" & i).Value Sh.Range("b" & R).Value = Range("g" & i).Value Sh.Range("c" & R).Value = Range("c" & i).Value Sh.Range("d" & R).Value = Range("f" & i).Value R = R + 1 n = n + 1 End If Next i If n > 0 Then MsgBox "تم ترحيل البيانات بنجاح" Else MsgBox "البيانات محدثة مسبقا" End If End Sub

تفضل اخي الكريم جرب هدا Sub Find_MissingNumbers() Dim WS As Worksheet Dim CodeArr() As Variant, NumArr() As Variant, code As Variant Dim tmp As Object, ling As Long, cnt As Boolean, n As Boolean Dim lastRow As Long, i As Long, j As Long, maxNum As Long Set WS = Sheets("Sheet1") lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row maxNum = 100 '(عدد الأصناف) ' تحديد الحد الاقصى للقيم المفقودة n = False For i = 3 To lastRow If Not IsEmpty(WS.Cells(i, 1).Value) And Not IsEmpty(WS.Cells(i, 2).Value) Then n = True Exit For End If Next i If Not n Then MsgBox "الرجاء التحقق من البيانات والمحاولة مرة أخرى", vbExclamation Exit Sub End If Application.ScreenUpdating = False On Error Resume Next WS.Range("F3:G" & WS.Rows.Count).ClearContents CodeArr = WS.Range("A3:A" & lastRow).Value NumArr = WS.Range("B3:B" & lastRow).Value Set tmp = CreateObject("Scripting.Dictionary") For i = 1 To UBound(CodeArr, 1) If Not tmp.Exists(CodeArr(i, 1)) Then tmp.Add CodeArr(i, 1), New Collection End If tmp(CodeArr(i, 1)).Add NumArr(i, 1) Next i On Error GoTo 0 ling = 3 For Each code In tmp.Keys For j = 1 To maxNum cnt = False For i = 1 To tmp(code).Count If tmp(code)(i) = j Then cnt = True Exit For End If Next i If Not cnt Then WS.Cells(ling, 6).Value = code WS.Cells(ling, 7).Value = j ling = ling + 1 End If Next j Next code Application.ScreenUpdating = True End Sub في حالة الرغبة بالحصول على رسالة تعرض "كود الصنف" وعدد "الأرقام المفقودة" لكل صنف بعد تنفيد الكود قم بتعديل الجزء الأخير من الكود كالتالي ling = 3 Dim msg As String, KyCount As Long msg = ": ملخص الأرقام المفقودة" & vbCrLf & vbCrLf For Each code In tmp.Keys KyCount = 0 For j = 1 To maxNum cnt = False For i = 1 To tmp(code).Count If tmp(code)(i) = j Then cnt = True Exit For End If Next i If Not cnt Then WS.Cells(ling, 6).Value = code WS.Cells(ling, 7).Value = j ling = ling + 1 KyCount = KyCount + 1 End If Next j msg = msg & "كود الصنف: " & code & " - عدد الأرقام المفقودة: " & KyCount & vbCrLf Next code Application.ScreenUpdating = True MsgBox msg, vbInformation, "نتيجة الأرقام المفقودة" End Sub الأرقام الناقصة v1.xlsb

اعرض الملف ✨نصوص متحركة ✨ .. 4 أربعة أشكال متنوعة مما لذ وطاب 😊👌 السلام عليكم ورحمة الله وبركاته 🙂 هذي من بعض التجارب على عمل أشكال جديدة على النصوص المتحركة .. وقد خلصت التجارب إلى التالي 🙂 للاستفادة من المثال : لدينا أربعة نماذج ، كل واحد منها يحتوي على أحد الأشكال الموضحة بالترتيب .. قم بفتح النموذج المراد تطبيقه ثم أنقل الأكواد مثل ما هي إلى برنامجك + الليبل الموجود في النموذج ( ويمكنك أستخدام الليبل الخاص بك ) قم فقط بتعديل النص المراد تحريكة + اسم الليبل الذي سيتحرك النص بداخله . صاحب الملف Moosak تمت الاضافه 03 أكت, 2024 الاقسام قسم الأكسيس  

شكررررررررا اخي هشام هو المطلوب

محمد احمد لطفى ... كتر الف خيرك ده بالظبط اللى انا عايزه

شكرا جزيلا

استاذ @Foksh 🌹❤️☕ ان شاء الله تكون بخير والله يعينك على شغلك الثاني من جهة حديث الاداة 1- عرض البيانات على نطاق الجغرافي 2- عمل نسخة احتياطية لكل قاعدة مضافة ونسخة تلقائية 3- ترحيل كافة الحسابات المنتهية بقواعد البيانات المضافة 4- خيار عرض معلومات المدنية ==========================( تحديث الاداة) 1- عمل تحديد عدد النسخ الاحتياطية على سبيل المثال اذا اخترة 10 نسخ اذا وصل 11 نسخة يحذف الاول القديم ويحتفظ على اقصى عدد 10 ويمكنك الاختيار Back_UP_Auto Clean Old db ====== 2- جلب بيانات المدنية عند العثور بدل من عرض القاعدة المرتبطة فقط مع خيار التشغيل النموذج 3- عرض نموذج ادخل الرقم المدني فقط وعرض البيانات 4- مع هدية 😏 ============( فيديو ) تحميل الاداة https://www.mediafire.com/file/zwpivi0mufmhlms/Update_Link_db_Ms_Access.rar/file

تفضل بالتوفيق عن طريق التنسيق الشرطى test13102024.rar

عليكم السلام .. وحياك الله بين اخوانك هذا كود فتح نموذج من نموذج آخر على حقل محدد Dim stDocName As String Dim stLinkCriteria As String stLinkCriteria = "passenger=forms!srch!t" stDocName = "data1" DoCmd.OpenForm stDocName, , , stLinkCriteria ويمكن اختصاره هكذا وسيعمل DoCmd.OpenForm "data1", , , "passenger=forms!srch!t" egypt 2.rar

تفضل أخي Sub Find_MissingNumbers3() Dim WS As Worksheet, dest As Worksheet Dim CodeArr() As Variant, NumArr() As Variant, code As Variant Dim tmp As Object, ling As Long, cnt As Boolean, n As Boolean Dim lastRow As Long, i As Long, j As Long, maxNum As Long Dim msg As String, KyCount As Long Set WS = Sheets("Sheet1") Set dest = Sheets("Sheet2") lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row maxNum = 100 ' تحديد الحد الاقصى للقيم المفقودة n = False For i = 3 To lastRow If Not IsEmpty(WS.Cells(i, 1).Value) And Not IsEmpty(WS.Cells(i, 2).Value) Then n = True Exit For End If Next i If Not n Then MsgBox "الرجاء التحقق من البيانات والمحاولة مرة أخرى", vbExclamation Exit Sub End If Application.ScreenUpdating = False dest.Range("a2:b" & dest.Rows.Count).ClearContents WS.Range("F3:G" & WS.Rows.Count).ClearContents CodeArr = WS.Range("A3:A" & lastRow).Value NumArr = WS.Range("B3:B" & lastRow).Value Set tmp = CreateObject("Scripting.Dictionary") For i = 1 To UBound(CodeArr, 1) If Not tmp.Exists(CodeArr(i, 1)) Then tmp.Add CodeArr(i, 1), New Collection End If tmp(CodeArr(i, 1)).Add NumArr(i, 1) Next i dest.Cells(2, 1).Value = "كود الصنف" dest.Cells(2, 2).Value = "عدد الأرقام المفقودة" ling = 3 Dim a As Long a = 3 For Each code In tmp.Keys KyCount = 0 For j = 1 To maxNum cnt = False For i = 1 To tmp(code).Count If tmp(code)(i) = j Then cnt = True Exit For End If Next i If Not cnt Then WS.Cells(ling, 6).Value = code WS.Cells(ling, 7).Value = j ling = ling + 1 KyCount = KyCount + 1 End If Next j dest.Cells(a, 1).Value = code dest.Cells(a, 2).Value = KyCount a = a + 1 Next code Application.ScreenUpdating = True MsgBox dest.Name & " تم ترحيل ملخص الأرقام المفقودة إلى", vbInformation End Sub الأرقام الناقصة v2.xlsb

ماشاء الله احسنت ا/ هشام محمد انت رائع حقا ماشاء الله احسنت ا/ هشام محمد انت رائع حقا

جزاك الله خيرا هو ده المطلوب

ادن قم بتغيير الجزء الأخير من الكود على الشكل التالي ليتناسب مع طلبك Private Sub ComboBox1_AfterUpdate() 'Code................ ' ترتيب أبجدي Tbl = j.Keys SrtArr Tbl Me.ComboBox2.Clear Me.ComboBox2.List = Tbl End Sub '============ Sub SrtArr(a As Variant) Dim temp As Variant Dim i As Long, j As Long Dim num1 As Long, num2 As Long Dim txt1 As String, txt2 As String For i = LBound(a) To UBound(a) - 1 For j = i + 1 To UBound(a) txt1 = Trim(Split(a(i), " ")(0)) On Error Resume Next num1 = CLng(Split(a(i), " ")(1)) On Error GoTo 0 txt2 = Trim(Split(a(j), " ")(0)) On Error Resume Next num2 = CLng(Split(a(j), " ")(1)) On Error GoTo 0 If num1 > num2 Then temp = a(i) a(i) = a(j) a(j) = temp End If Next j Next i End Sub ترتيب البيانات ابجديا v3.xlsm

وعليكم السلام بطريقه اخرى عن طريقه اخى العزيز @Foksh بدون الاستعلام الفرعى الداخلى جزاه الله خير 🌹 SELECT Last([s10].[g10s1]) AS Lastg10s1, Last([s10].[g1s29]) AS Lastg1s29, Max([s10].[g1s30]) AS Maxg1s30 FROM s10 WHERE (((s10.g1s1)=[Forms]![copy2]![g1s1])); copy_1.accdb

الاجمل هو مشاركتكم معنا ومساندتنا دائما وتوجيهنا للصواب ان اخطئنا جزاكم الله عنا كل خير 🌹

وعليكم السلام ورحمة الله وبركاته ،، فقط استبدل مصدر سجلات النموذج الفرعي ، بالإستعلام التالي ( SQL ) :- SELECT s10.g10s1, s10.g1s1, s10.g1s29, s10.g1s30 FROM s10 WHERE (((s10.g1s1)=[Forms]![copy2]![g1s1]) AND ((s10.g1s30)=(SELECT MAX(g1s30) FROM s10 WHERE g1s1 = [Forms]![copy2]![g1s1] ))); حيث تم اضافة شرطين للإستعلام دون تغيير أو تعديل أي شيء في تصميمك ، ولكني أنصحك بالإبتعاد عن المسميات المحجوزة في آكسيس مثل Copy لإنه اسم إجراء في آكسيس ؛ وهذا سيلافيك حدوث أخطاء ومشاكل في المستقبل . ملفك بعد التعديل : ( copy.accdb )

المعادلة =IF(B2="";"";IF(B2<=C2;2%;"1%")) الملف تحقق التارحت.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته بعد إدن الاستاد @عبدالله بشير عبدالله اليك حل اخر Option Compare Text Option Explicit Dim f As Worksheet Private Sub UserForm_Initialize() Set f = ThisWorkbook.Sheets("Sheet3") Dim j As Object, OneRng As Variant, i As Long, Tbl As Variant Set j = CreateObject("Scripting.Dictionary") OneRng = f.Range("D2:D" & f.Cells(f.Rows.Count, "D").End(xlUp).Row).Value ' تعبئة كومبوبوكس 1 بالقيم غير الفارغة والغير مكررة For i = LBound(OneRng, 1) To UBound(OneRng, 1) If OneRng(i, 1) <> "" Then j(OneRng(i, 1)) = "" Next i ' ترتيب أبجدي Tbl = j.Keys SrtArr Tbl, LBound(Tbl), UBound(Tbl) Me.ComboBox1.List = Tbl End Sub Private Sub ComboBox1_AfterUpdate() If f Is Nothing Then Set f = ThisWorkbook.Sheets("Sheet3") Dim j As Object, OneRng As Variant, i As Long, Tbl As Variant Set j = CreateObject("Scripting.Dictionary") OneRng = f.Range("D2:D" & f.Cells(f.Rows.Count, "D").End(xlUp).Row).Value ' تعبئة كومبوبوكس 2 بالقيم غير الفارغة والغير مكررة وأنها لا تطابق قيمة كومبوبوكس 1 For i = LBound(OneRng, 1) To UBound(OneRng, 1) If (OneRng(i, 1) <> "") And (CStr(OneRng(i, 1)) <> Me.ComboBox1.Value) Then j(OneRng(i, 1)) = "" Next i ' ترتيب أبجدي Tbl = j.Keys SrtArr Tbl, LBound(Tbl), UBound(Tbl) Me.ComboBox2.Clear Me.ComboBox2.List = Tbl End Sub Sub SrtArr(a As Variant, gauc As Long, droi As Long) Dim ref As Variant, temp As Variant Dim g As Long, D As Long ref = a((gauc + droi) \ 2) g = gauc: D = droi Do Do While a(g) < ref: g = g + 1: Loop Do While ref < a(D): D = D - 1: Loop If g <= D Then temp = a(g): a(g) = a(D): a(D) = temp g = g + 1: D = D - 1 End If Loop While g <= D If g < droi Then SrtArr a, g, droi If gauc < D Then SrtArr a, gauc, D End Sub ترتيب البيانات ابجديا v2.xlsm

اخي العزيز الغالي ابو بسملة .. جميلة جدا هذه الاستعارة .. في ردي السابق نسيت ان اربط النموذج بالبيانات .. تجدون ادناه تعديل لمرفقي السابق test12.rar

السلام عليكم مشاركه مع اخوتى واساتذتى جزاهم الله عنا خيرا بطريقه اخرى عن طريقه اخى واستاذى وشيخنا الجليل @ابوخليل test 110.accdb

اخوي احمد .. الله يكون بعونك .. ستتعب كثيرا test11.rar

الكود يرتب ابجدي ويحذف التكرار Private Sub UserForm_Initialize() Dim ws As Worksheet Dim rng As Range Dim data As Variant Dim sortedData As Variant Dim uniqueData As Collection Dim i As Long, j As Long Dim temp As Variant Set ws = ThisWorkbook.Sheets("Sheet3") Set rng = ws.Range("D2:D" & ws.Cells(ws.Rows.Count, "D").End(xlUp).Row) data = rng.Value ReDim sortedData(1 To UBound(data, 1), 1 To 1) For i = 1 To UBound(data, 1) sortedData(i, 1) = data(i, 1) Next i For i = 1 To UBound(sortedData, 1) - 1 For j = i + 1 To UBound(sortedData, 1) If sortedData(i, 1) > sortedData(j, 1) Then temp = sortedData(i, 1) sortedData(i, 1) = sortedData(j, 1) sortedData(j, 1) = temp End If Next j Next i Set uniqueData = New Collection On Error Resume Next For i = 1 To UBound(sortedData, 1) uniqueData.Add sortedData(i, 1), CStr(sortedData(i, 1)) Next i On Error GoTo 0 With Me.ComboBox1 .Clear For i = 1 To uniqueData.Count .AddItem uniqueData(i) Next i End With With Me.ComboBox2 .Clear For i = 1 To uniqueData.Count .AddItem uniqueData(i) Next i End With End Sub الملف ترتيب البيانات ابجديا.xlsm

بعد ادن الاساتدة هذه محاولة Customers-Project-01.xlsm

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

وعليكم السلام ورحمة الله تعالى وبركاته جرب هذا مع تغيير أسماء الأعمدة بما يناسبك =SUMPRODUCT(--(B2:B12<>"")*(B2:B12<>"غ")*(B2:B12<>"غياب")*(B2:B12<>"تخلف")) المصنف1.xlsx

يمكنك استعمال هذه المعادلة في الخلية D6 =IFERROR(INDEX(الاسماء!$G$6:$G$215,MATCH(الخطة!D6,الاسماء!$F$6:$F$215,0)),"") ثم سحب المعادلة للأسفل ويسارا وإذا كنت تستعمل النسخ الحديثة للأوفيس يمكنك استعمال هذه المعادلة بدون سحب في الخلية D6 فقط' =IFERROR(INDEX(الاسماء!$G$6:$G$215,MATCH(الخطة!D6:AD230,الاسماء!$F$6:$F$215,0)),"") بالتوفيق

حضرتك ارجع للملف المعادلة في العمود G صحيحة وتعطي نواتج مطابقة تماما للحساب اليدوي غي العمود I ويمكنك حذف العمود H المعادلة القديمة

استخدمت المعادلة الموضحة بالصورة وهي =IFERROR(XLOOKUP(A3;'وارد-صادر'!$A$4:$A$95;'وارد-صادر'!$E$3:$E$94;0);"0") وهي موجود بالاصدار 2019

اعتقد ماجربت الملف الذي ارفقته انظر للصورة لايوجد قيم للايام التي هي 0

بعد تغيير النطاق في معادلة sumif Alyosr IncomingsTest2.xlsx

فضلا جرب المرفق ادناه بعد اضافة المعادلة =SUMIF('وارد-صادر'!A:F;A3;'وارد-صادر'!E:E) Alyosr IncomingsTest2.xlsx

السلام عليكم اذا كان المطلوب حساب جملة الربح المحقق خلال تاريخ يوم معين فيمكن استخدام دالة SUMIF كما بالمرفق Alyosr IncomingsTest1.xlsx

=VLOOKUP(A7;'وارد-صادر'!A8:F73;5) بس عندي ملاحظات على الدالة اعلاه انه في حالة تكرار نفس التاريخ سياخذ اخر نتيجة اخر تاريخ ممكن تبعث الملف بالنتائج المطلوبة يدويا لنتمكن من اضافة المعادلات الصحيحة

السلام عليكم اعلم انه قد اطلع علي الموضوع العديد من خبراء المنتدي واعلم انه محاولة ايجاد حل المشكلة بعد مرور السادة الخبراء بهذا الموضوع شيئ يصعب حتي التفكير فيه . لكن لي سؤال قد يكون هو نفسة حل المشكلة لماد تم بناء المعادلة بهذه الطريقة =VLOOKUP($A7;'وارد-صادر'!$A$4:$E$98;'وارد-صادر'!E3:E100;1) في حين اني اعلم بخبرتي البسيطة ان المعامل الثالث يكون ترتيب العمود الموجود به القيمة المراد جلبها من الجدول او النطاق المحدد وهي هنا العمود رقم 5 لتصبح المعادلة =VLOOKUP($A7;'وارد-صادر'!$A$4:$E$98;5;1) وتعطي ناتج 300 في الصف رقم 7 Alyosr IncomingsTest1.xlsx