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

السلام عليكم عيدكم مبارك بالمرفق كود يقوم نيابة عنك بإكمال البيان الذي تكتبه في عمود معين بورقة عمل استناداً لمجال معين بورقة عمل آخري منفصلة. كيف ؟؟؟؟ الشرح : 1- قم بتدوين البيانات التي تريدها في المجال المسمى AutoCompleteText ضمن العمود A بالورقة المسماة Source data يجب أن تكون البيانات المدخلة غير مكررة . 2- الان انتقل إلى العمود A بالورقة المسماة Test sheet وقم بكتابة الأحرف الأولى المميزة والفريدة لأحد البيانات التي دونتها بالمجال السابق ثم اضغط Enter ،، سيكمل الكود البيان الذي كتبته سلفاً ،،، على سبيل المثال : اكتب حرف Z ثم اضغط Enter ستكون النتيجة في الخلية ZIAD ALI - لأنه النص الوحيد الذي يبدأ بالحرف Z ،،، واذكر بأنه ممكن أن تقوم بزيادة عدد الأعمدة التي ترغب أن يتم فيها عملية استرجاع البيانات بالصفحة المسماة Test sheet عن طريقة التعديل في الكود أرجو أن يكون المرفق مفيد للجميع ،،، ولكم كل الود والتحية. الاكمال التلقائي للبيانات.rar

مشاركة مع احبتي .. وهو مجرد رأي رأيي ان الطريقة في المثال كافية ومثالية بدلا من الزحمة وعمل متصفح داخل النموذج ولتلافي تراكم الصور يتم حذف الصورة آليا عند غلق النموذج

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاخ @abouelhassan بما انك ترغب بتنفيد المعادلات على شكل كود اليك حل اخر رغم انني لا اعلم ما هي الطريقة المطلوبة لتنفيده Sub sheets_arrformula() 'Execute On All Worksheets Dim wsName As Worksheet, desWS As Worksheet Dim lr As Long, lige As Long Dim ws As Worksheet: Set ws = Sheets("بيانات رئيسية") For Each wsName In ThisWorkbook.Worksheets If wsName.Name Like "*-JAN" Then 'في حالة اظافة اوراق اخرى للمصنف 'Example February March.......... 1-Feb ,2-Feb.......1-Mar ,2-Mar 'If wsName.Name Like "*-*" Then With Application .ScreenUpdating = False .Calculation = xlManual Set desWS = ThisWorkbook.Sheets(wsName.Name) lr = ws.Columns("A:D").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set a = ws.Range("A2:A" & lr): Set b = ws.Range("B2:B" & lr) Set c = ws.Range("C2:C" & lr): Set d = ws.Range("D2:D" & lr) f = ws.Name lige = desWS.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row - 1 desWS.Range("B2:C" & lige).ClearContents With desWS.Range("B2:B" & lige) .Formula2 = "=IFERROR(INDEX('" & f & "'!" & c.Address & ",MATCH(1,(E$1 ='" & f & "'!" & a.Address & ")*(A2 ='" & f & "'!" & b.Address & "),0)),"""")" .Value = .Value With desWS.Range("C2:C" & lige) .Formula2 = "=IF($B2<>"""",SUMIFS('" & f & "'!" & d.Address & ",'" & f & "'!" & a.Address & ",""=""&$E$1,'" & f & "'!" & c.Address & ",""=""&$B2,'" & f & "'!" & b.Address & ",a2),"""")" .Value = .Value End With End With .ScreenUpdating = True .Calculation = xlAutomatic End With End If Next wsName End Sub ولتنفيد الكود على الورقة النشطة Sub Test2() 'Execute On the Active Worksheet Dim lr As Long, lige As Long Dim ws As Worksheet: Set ws = Sheets("بيانات رئيسية") Dim desWS As Worksheet: Set desWS = ActiveSheet With Application .ScreenUpdating = False .Calculation = xlManual lr = ws.Columns("A:D").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row f = ws.Name Set a = ws.Range("A2:A" & lr): Set b = ws.Range("B2:B" & lr) Set c = ws.Range("C2:C" & lr): Set d = ws.Range("D2:D" & lr) If desWS.Name <> f Then lr = ws.Columns("A:D").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set a = ws.Range("A2:A" & lr): Set b = ws.Range("B2:B" & lr) Set c = ws.Range("C2:C" & lr): Set d = ws.Range("D2:D" & lr) f = ws.Name lige = desWS.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row - 1 desWS.Range("B2:C" & lige).ClearContents With desWS.Range("B2:B" & lige) .Formula2 = "=IFERROR(INDEX('" & f & "'!" & c.Address & ",MATCH(1,(E$1 ='" & f & "'!" & a.Address & ")*(A2 ='" & f & "'!" & b.Address & "),0)),"""")" .Value = .Value With desWS.Range("C2:C" & lige) .Formula2 = "=IF($B2<>"""",SUMIFS('" & f & "'!" & d.Address & ",'" & f & "'!" & a.Address & ",""=""&$E$1,'" & f & "'!" & c.Address & ",""=""&$B2,'" & f & "'!" & b.Address & ",a2),"""")" .Value = .Value End With End With End If .ScreenUpdating = True .Calculation = xlAutomatic End With End Sub مصنف v2.xlsm

السلام عليكم ورحمة الله وبركاته اخى الفاضل @kkfhvvv تفضل هذا الكود يقوم بتصفية البيانات للثلاث الاعمدة جربه لعله يكون المطلوب Sub RemoveDuplicatesRange() Dim lastRow As Long lastRow = Sheets("البيانات").Cells(Sheets("البيانات").Rows.Count, "O").End(xlUp).Row Sheets("البيانات").Range("O1:Q" & lastRow).Copy Sheets("ارقام").Range("A1").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False lastRow2 = Sheets("ارقام").Cells(Sheets("ارقام").Rows.Count, "A").End(xlUp).Row Sheets("ارقام").Range("$A$2:$C$" & lastRow2).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo End Sub تقبل تحياتى

انا اسف اخى طريقة عرض طلبك يجب ان تبدأ بالسلام عليكم اخوانى وتكتب طلبك ودعم الطلب بملف عموما جرب واخبرنى يمكنك وضع الكود في وحدة VBA في ملف Excel وسيعمل تلقائيًا بمجرد فتح الملف. إليك الخطوات لوضع الكود وجعله يعمل بشكل تلقائي بدون الحاجة لزر: 1. افتح ملف Excel الذي تريد إضافة الكود إليه. 2. اضغط `Alt` + `F11` لفتح محرر VBA. 3. في القائمة، اختر `Insert` > `Module` لإنشاء وحدة VBA جديدة. 4. الصق الكود في وحدة VBA التي تم إنشاؤها. 5. اضغط `Ctrl` + `S` لحفظ الملف. 6. أغلق محرر VBA. 7. أغلق الملف وأعد فتحه. الآن، سيعمل الكود تلقائيًا عند فتح الملف، حيث سيقوم بحفظ وإغلاق الملف تلقائيًا بعد مرور 5 دقائق من الخمول. Dim StartTimer Const IdleTime = 5 ' وقت الخمول بالدقائق Sub ResetTimer() StartTimer = Now End Sub Sub CheckIdleTime() If (Now - StartTimer) * 24 * 60 > IdleTime Then Application.DisplayAlerts = False ' لعدم عرض رسائل التنبيه ThisWorkbook.Save ' حفظ الملف ThisWorkbook.Close ' إغلاق الملف Application.DisplayAlerts = True End If End Sub Private Sub Workbook_Open() StartTimer = Now Application.OnTime Now + TimeValue("00:01:00"), "CheckIdleTime" ' فحص الوقت كل دقيقة End Sub Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) ResetTimer End Sub Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) ResetTimer End Sub Private Sub Workbook_SheetActivate(ByVal Sh As Object) ResetTimer End

جرب هدا الحل بعد اظافة اليوزرفورم هل يناسبك باسوورد 0 الاعمال الجنوبية userform.xlsm

السلام عليكم هذا الجزء في التصميم تم التطرق اليه في هذا المنتدى ومن يبحث يجد الكثير .. علما اني قد استفدت واخذت من تلك المواضيع فما انا الا ناقل .. والعلم تراكمي ينتقل ويتزايد . وحتى يكون هذا الموضوع مرجع مختصر يتم نقله فقط الى برنامجك .. لذا عملت على اعداد مثال صغير وهو عبارة عن جدول ونموذج ووحدة نمطية ويتم من خلاله رصد التالي : - معرف السجل - اسم الحقل - اسم النموذج - القيمة الأساسية ( قبل التعديل ) - القيمة الجديدة (بعد التعديل ) - اسم المستخدم - تاريخ ووقت التعديل مع امكانية التصفية والبحث بين تاريخين -------------------------------------------------------------- كل ما عليك عمله هو : اولا : نقل الكائنات التالية (جدول/نموذج/وحدة نمطية) الى برنامجك : modAudit / frmAudit / tblAudit ثانيا : اي نموذج في مشروعك ترغب في تتبع التعديلات التي تجري عليه .. فقط الصق فيه هذا الكود في حدث قبل التحديث Private Sub Form_BeforeUpdate(Cancel As Integer) Dim x As Integer If Not IsNull(Me!ID) Then x = WriteAudit(Me, Me!ID) End If End Sub ID يمثل الحقل الفريد داخل النموذج هذا كل شيء ... ---------------------------------------------------------------------------------------------------------------------------------------- نأتي للتفاصيل التي استبعدتها وهي محل النقاش لمن اراد المشاركة . وهي ان الوظيفة تخص تتبع الحقول النصية فقط ، واريد ضم مربع التحرير وكما هو ظاهر في المثال المرفق .. قيمة مربع التحرير "رقمية" والمطلوب اظهار القيمة "النصية" الأساسية ( التي تم تغييرها) ، اظهارها في جدول التتبع اما بالنسبة للقيمة الجديدة فلا اشكال فيها انا عالجت المسألة ووصلت الى حل ولكن بطريقة مطولة فنريد الاستفادة من الخبراء الأفاضل حول هذه النقطة و لأخي @Moosak خاصه تعقيبا على تعليقه هنا ------------------------------------------------------------------------------------ وقد اجاب الاستاذ موسى والاستاذ فادي وأجادا بمثالين احترافيين شاملين فجزاهما الله خيرا 1- المرفق Database2 وهو خاص بالحقول النصية 2- المرفق Track Changes - Moosak شامل الحقول النصية ومربعات التحرير 3- المرفق Database5 شامل الحقول النصية ومربعات التحرير بقي الاختيار لك فاختر ما يناسبك . Track Changes - Moosak.accdb Database2.rar Database5.accdb

للتوضيح : لاسخراج جميع الاوراق في ملف PDF واحد يتضمن جميع الطلاب ربما يتعين عليك مثلا نسخ جميع الاوراق المطبوعة لورقة اخرى اسفل بعضها البعض لتتمكن من حفظها بعد دالك . وهدا يتطلب اظافة ورقة جديدة للمصنف مع انشاء الكود الخاص بدالك . اما في حالة الرغبة في حفظها مستقلة اليك الكود التالي سيقوم بحفظ كل ورقة لوحدها في مجلد باسم شهادات الطلاب بعد تسمية كل ملف باسم الطالب الخاص به Private Sub CommandButton1_Click() Dim i As Integer, fPath As String, F As String Dim WS As Worksheet: Set WS = Sheet31 'Sheets("Sheet3 (2)") ' اسم ورقة العمل Application.ScreenUpdating = False For i = [AA12] To [AC12] If i <= [AA1] Then [AF2] = 2 * (i - 2) + 3 F = [B8] ' اسم الملف On Error Resume Next With ActiveWorkbook ' قم بتعديل اسم المجلد بما يناسبك fPath = .Path & Application.PathSeparator & "شهادات الطلاب" & Application.PathSeparator If Len(Dir(fPath, vbDirectory)) = 0 Then End If MkDir fPath WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fPath & "\" & F & ".pdf", OpenAfterPublish:=False 'طباعة 'WS.PrintOut End With Next i Application.ScreenUpdating = True End Sub 666 PDF.xlsm

فقط المحدد ..... جرب

مشكور جدا اخي الغالي Foksh وصلت وهو المطلوب تحياتي لك يالغالي

من مصدر بيانات النموذج قم باختيار جميع الحقول ، ثم في حقل P ODate اكتب الشرط <Date() ونصيخة من أخيك ( عن تجربة ) استبدل المسافة التي بين المسميات بإشارة _

بالطريقة التي تم فيها عرض السجلات لا اعتقد انه من الممكن تنفيذ فكرتك 😬

من االافضل دكر ما هي النتيجة المتوقعة من الكود جرب ربما هدا ما تقصد Sub HideRowsPrint() Dim i As Long, LastRow As Long Application.ScreenUpdating = False StartRow = 9: LastRow = 300 For i = LastRow To StartRow Step -1 If Cells(i, "C") = "" Then Rows(i).Hidden = True Next i Application.ScreenUpdating = True ActiveSheet.PrintPreview ' ActiveSheet.PrintOut Rows(StartRow & ":" & LastRow).EntireRow.Hidden = False End Sub

تفضل .. fatherAnd Son (1).accdb

وعليكم السلام ورحمة الله تعالى وبركاته Sub SaveFile_Excel() 'في نفس مسار المصنف الرئيسي Excel 'حفظ بصيغة Dim WS As Worksheet, Client As String, path As String, Msg As Variant path = ThisWorkbook.path & "\" Set WS = Worksheet____3: Client = [D3].Value If Len([D3].Value) = 0 Then: MsgBox "المرجوا إظافة إسم العميل", vbExclamation, "Admin": Exit Sub Msg = MsgBox(" تصدير الملف" & " : " & "فاتورة" & " " & Client & "؟", vbYesNo, "Admin") If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False WS.Copy Set rng = [B1:F22] With rng .Value = .Value .Validation.Delete End With For Each shape In ActiveSheet.Shapes shape.Delete Next Application.ActiveWorkbook.SaveAs Filename:=path & Client & ".xlsx", FileFormat:=51 '<-- اظافة التوقيت ' Application.ActiveWorkbook.SaveAs Filename:=Path & Client & "-" & Format(Time, "HH-mm-ss") & ".xlsx", FileFormat:=51 ActiveWorkbook.Close .ScreenUpdating = True .DisplayAlerts = True End With MsgBox "تم نسخ الملف بنجاح" & _ "", vbInformation, Client End Sub حسابات احمد.xlsb

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

متابعةً مع أستاذنا @Moosak ، تم إضافة بعض التعديلات حسب طلبك . تفضل الكود أولاً . Option Compare Database Option Explicit Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private bMessage20Displayed As Boolean ' متغير لتتبع ما إذا تم عرض الرسالة عند 20% Private bMessage50Displayed As Boolean ' متغير لتتبع ما إذا تم عرض الرسالة عند 50% Private Sub StartBtn_Click() Call ResetProgressPar Call RunProgressPar End Sub Function ResetProgressPar() ' Reset Me.Par2.Left = Me.Par1.Left Me.Par2.Height = Me.Par1.Height Me.Par2.Width = 0 Me.P = "" bMessage20Displayed = False ' إعادة تعيين قيمة المتغير bMessage50Displayed = False ' إعادة تعيين قيمة المتغير End Function Function RunProgressPar() ' Start Dim x As Long Dim percentage As Double For x = 1 To Par1.Width Step 2 Me.Par2.Width = x percentage = CInt((x / Par1.Width) * 100) Me.P = percentage & " %" If percentage = 20 And Not bMessage20Displayed Then MsgBox "20% progress. Press OK to continue.", vbInformation, "Progress Update" bMessage20Displayed = True Sleep 500 End If If percentage = 50 And Not bMessage50Displayed Then MsgBox "50% progress. Press OK to continue.", vbInformation, "Progress Update" bMessage50Displayed = True Sleep 500 End If DoEvents Next End Function تفضل المرفق ، طبعاً قم بتغيير حدث الرسالة بالحدث الذي ترغب به شريط تقدم بدون تايمر.accdb

أخي سامر أرجو منك التوجه لتعديل المسميات في الجداول إلى اللغة الإنجليزية ليصبح لديك عمل سليم في التأسيس ، فالمسميات لديك عربي وانجليزي على العموم اخي الكريم قمت بانشاء استعلام تحديث Query1 لاضافة السجلات الى جدول الحركة ، أما الإستعلام DO ، فأعتقد يحتاج إعادة ضبط حسب مسمياتك . فقط لا غير

أخي العزيز @سامر محمود جرب هذا التعديلات التي تمت على العلاقات Unif.accdb

ممكن تستخدم الاكواد الاتيه للاخفاء الصفوف واظهارها Sub اخفاء() Dim Cl As Range For Each Cl In Range("a3:a103") If Cl.Value = Range("k2") Then Cl.EntireRow.Hidden = True End If Next Cl End Sub Sub اظهار() Dim Cl As Range For Each Cl In Range("a3:a103") If Cl.Value = Range("k2") Then Cl.EntireRow.Hidden = False End If Next Cl End Sub

ستم متابعة الفكرة أخي الكريم وإضافتا في التحديثات القادمة ، ولا يهمك أشكرك على ملاحظتك

تفضل محاولة متواضعة fatherAnd Son.accdb

Sub SaveAsNewWorkbook() Dim wb As Workbook Dim ws As Worksheet Dim newWb As Workbook Dim newWs As Worksheet Dim folderPath As String Dim clientName As String Dim lastRow As Long ' تحديد المجلد المحتوي على الملف الأصلي folderPath = ThisWorkbook.Path ' اسم العميل (يمكنك تغيير هذا إلى الطريقة التي تريد استخدامها لاستخراج اسم العميل) clientName = "اسم العميل" ' تكوين اسم الملف الجديد newFileName = folderPath & "\" & clientName & ".xlsx" ' نسخ ورقة العمل الحالية إلى مصفوفة Set wb = ThisWorkbook Set ws = wb.ActiveSheet ws.Copy ' حفظ المصفوفة كملف إكسل جديد Set newWb = ActiveWorkbook Set newWs = newWb.Sheets(1) Application.DisplayAlerts = False newWb.SaveAs newFileName, FileFormat:=xlOpenXMLWorkbook Application.DisplayAlerts = True ' تحويل المعادلات في النصف العلوي من الفاتورة إلى قيم lastRow = newWs.Cells(Rows.Count, "A").End(xlUp).Row newWs.Rows("1:" & lastRow \ 2).Value = newWs.Rows("1:" & lastRow \ 2).Value ' إظهار رسالة تأكيد الحفظ MsgBox "تم حفظ الملف كـ" & newFileName, vbInformation, "تم الحفظ" End Sub يرجى ملاحظة أنه يجب استبدال "اسم العميل" بالطريقة التي تريد استخدامها لاستخراج اسم العميل

السلام عليكم استاذ ابوالحسن بعتذر عند مخالفه قواعد المدونه لانى لسه جديد بها وبشكر حضرتك على الاكواد الحمدلله اشتغلت بنسبه 100%

كلام صحيح استاذي @Foksh حاولت اجد طريقة لعرضها مباشرة .. لم اتوصل اليها ... جاري المحاولة ... طيب لو كان عرض الصورة في متصفح مدرج في النموذج مناسب لعملك ... لاني لم اجربها هل تنجح ام لا ...

تفضل صديقنا العزيز ,, fatherAnd Son.accdb

أستاذ @kanory ، أشكرك جداً على مساهمتك الجميلة ، الفكرة حلوة ولكن هي تعتمد على تنزيل الصورة من المصدر وبعد ذلك يتم عرضها على أنها من مسار داخلي وليس من مسار خارجي URL .

جميل جدا جاري التجربة مع جزيل الشكر

ومشاركة في توضيح الفرق بين نوعي المتغيرات المتغير من نوع Integer لتخزن الأرقام الصحيحة ( بدون أعشار ) ، بينما المتغير من نوع Double يستخدم لتخزين الأرقام العشرية ( بما في ذلك الأعشار ) .

شكرا جزيلا لكل من اجابني على سؤالي ... جعلها ربي في ميزان حسناتكم ...

الف مبروك للاستاذ @محمد احمد لطفى ولو انها متأخرة ..فمنذ شهرين لم افتح الحاسوب لانشغالي ..واشياء اخرى امنياتي لك بالتوفيق والازدهار الدائم

ما شاء الله إلف إلف مبروك ... كفء والله

جرب Function GetCustomerData(customerCode As String, dataSheet As Worksheet) As Variant Dim dataRange As Range Dim result As Variant Set dataRange = dataSheet.Range("A:C") result = Application.WorksheetFunction.Index(dataRange.Columns(3), _ Application.WorksheetFunction.Match(1, (dataRange.Columns(1) = [E1]) * (dataRange.Columns(2) = customerCode), 0)) GetCustomerData = IIf(customerCode = "", "", result) End Function Function GetCustomerTotal(customerCode As String, dataSheet As Worksheet) As Variant Dim dataRange As Range Dim result As Variant Set dataRange = dataSheet.Range("A:D") result = Application.WorksheetFunction.SumIfs(dataRange.Columns(4), dataRange.Columns(1), [E1], dataRange.Columns(2), customerCode) GetCustomerTotal = IIf(customerCode = "", "", result) End Function

السلام عليكم ورحمة الله وبركاته ربنا اغفر لي ولوالديّ وللمؤمنين يوم يقوم الحساب جزاكم الله خيراً

اللهم اغفر له وارحمه، وعافه واعف عنه، وأكرم نزله، ووسع مدخله، واغسله بالماء والثلج والبرد، ونقه من الخطايا كما ينقى الثوب الأبيض من الدنس هو ووالدي وجميع موتى المسلمين

اسأل الله العلي القدير ان يرحم والدك ويرحم امواتنا جميعاً اللهم امين

وعليكم السلام ورحمة الله تعالى وبركاته بما ان البيانات من على النمودج ثابثة باستثناء( نوع الطلبية _ والوقت _ و رقم الطلبية) يمكنك محاولة ادراج ملخص الطلبية مباشرة بدون الاعتماد عليه جرب هدا الحل ربما يناسبك Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo Exitsub If Target.Row > 1 And Target.Column < 17 Then Dim lr As Long, r As Long Set WS = Sheet1 lr = WS.Range("i" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False With WS.Range("r2:r" & lr) .Formula = "=IF(I2<>"""",""في تمام الساعة( ""&CONCATENATE(TEXT(L2,""HH:mm"")&"" ) ""&""تم طلب "")&I2&"" ""&""منطقة (""&A2&"") "" &""وصول""&"" ""&"" ""&I2&"" ""&""الساعة""&"" ( ""&CONCATENATE(TEXT(N2,""HH:mm"")&"")""&"" ""&"" رقم الطلبية ( "")&F2&"") "","""")" .Value = .Value End With For r = 2 To WS.Cells(Rows.Count, "r").End(xlUp).Row If WS.Range("i" & r).Value = "" Then WS.Range("r" & r).Value = "" Next r End If Exitsub: End Sub نموذج V1.xlsm

وهذه مشاركتي البسيطة مع الأستاذ خليفة Sleep Mode.accdb

تفضل استاذ @Abdelaziz Osman مرفق من مكتبتي . Main_Form Close After 15 minute.rar

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

أخي الكريم تفضل طلبك بطريقتي Test Foksh.accdb

في حدث Private Sub Worksheet_Activate ضع الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) Dim a, i&, k&, b$, S$, lRow& Dim WS As Worksheet: Set WS = Sheets("البيانات") Dim desWS As Worksheet: Set desWS = Sheets("البحث") b = desWS.[E2] On Error Resume Next Application.ScreenUpdating = False If Not Intersect(Target, Target.Worksheet.Range("E2")) Is Nothing Then If Target.Cells.Value = "" Or IsEmpty(Target) Then Exit Sub desWS.Range("A5:j" & Rows.Count).ClearContents a = WS.Range("A3:J" & WS.[a65000].End(xlUp).Row) For i = 1 To UBound(a) If a(i, 4) = b Or a(i, 7) = b Or a(i, 10) = b Then desWS.Cells(k + 5, 1).Resize(, 10) = Application.IfError(Application.Index(a, i, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)), "") k = k + 1 ActiveWindow.DisplayZeros = False End If Next lRow = desWS.Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set Rng = desWS.Range("A5 :J" & lRow) desWS.Range("A5:J500").Borders.LineStyle = xlNone For Each c In Rng.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next Application.ScreenUpdating = True End If End Sub السيارات 24.xlsb

تفضل استاذ @فؤاد الدلوي المرفق بعد التعديل بطلبك . واذا كان هذا طلبك اضغط على أفضل إجابة . Test.rar

الف الف مبروك، وتحياتي لكل أعضاء المنتدى الغالي دمتم بالف خير 🌹🌹🌹

الف الف مبروك لك استاذ / @محمد احمد لطفى نتمني لك التوفيق ونفع الله بك وبعلمك

@محمد احمد لطفى الف مبروك وتستاهل فالك التوفيق والنجاح ونفع الله بك وبعلمك

الف الف الف مبروك

اللهم اغفر له وللمسلمين جميعا

بارك الله فيك وزادك الله من فضله اللهم اغفر لوالدك وارحمه، وعافه واعف عنه، وأكرم نزله، ووسع مدخله، واغسله بالماء والثلج والبرد، ونقه من الخطايا كما ينقى الثوب الأبيض من الدنس. - اللهم أبدله دارا خيرا من داره، وأهلا خيرا من أهله، وزوجا خيرا من زوجه، وأدخله الجنة، وأعذه من عذاب القبر، ومن عذاب النار

السلام عليكم فى الملف المرفق ملف لتحليل نتائج التلاميذ حسب التعليمات الوادره من الادارة التعليمية وهوا لم ينتهى بعد لمن اراد استكماله وهوا مفتوح ومن انتاج الاساتذه بهذا الصرح التعليمى الكبير ارجوا الاستفاده منه تحيل النتيجة تيرم ثان - العبور الابتدائية بخفرع 2018.rar