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

وعليكم السلام ورحمه الله وبركاته ممكن تستخدم الكود التالي لعله المطلوب 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 ذكرين_انثيين() 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

DC.xlsx

اتفضل الشيت بالكود المستخدم لعله يكون الطلوب وعدل عليه حسب ما تريد 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

الاستاذ أبو مروان أنا اتقدم إليك بخاص الشكر والعرفان وجزاك الله خيرا وبارك الله تعالى فيك

وعليكم السلام ورحمة الله تعالى وبركاته الإسم المفروض وضع الصيغة التالية في عمود الاسم لاكنها ستقوم باستخراج الأسماء مكررة بعدد تواجدها في عمود الإسم لهدا قم بوضعها مثلا في الخلية Q6 وسحبها للأسفل =IFERROR(INDEX(D$6:D$139,SMALL(IF($H$6=$C$6:$C$139,ROW($D$6:$D$139)-5),ROW(J1))),"") ثم وضع المعادلة التالية في الخلية K6 مع سحبها للأسفل لإستخراج الأسماء بدون تكرار =IFERROR(IF(Q6<>"", INDEX($Q$6:$Q$139, MATCH(0, COUNTIF($K$5:K5, $Q$6:$Q$139) + IF($Q$6:$Q$139="", 1, 0), 0)), ""), "") إجمالي الإسم =IF(K6<>"",SUMIF($D$6:$D$139, K6, $E$6:$E$139),"") إجمالي البيان =SUMIF(C6:C139, H6, E6:E139)

وعليكم السلام 🙂 تم مناقشة الموضوع في الرابط التالي ، ولا يوجد جديد من يوم الموضوع الى اليوم 🙂 وهذا هو الملخص: يمكن الحصول عليها ، وهناك العديد من البرامج اللي تعمل هذا الشيء ، لكن هذه برامج عامة تستخدم الطرق التقليدية في محاولات مقارنة كلمة السر ، والطرق الشهيرة هي: Dictionary Attack Brute-Force Attack Xieve Attack Known Password/Part Attack Previous Passwords Attack وكل نوع من هذه البرامج يشتغل بطريقة تختلف عن الأخرى ، ولكنها جميعا تحاول بزيادة/تغيير حرف/رقم/إشارة على الرقم/الكلمة اللي تم تجربتها ، وانا اعتقد بأن جميع الشباب اللي شاركوا في هذا الموضوع وحاولوا استخراج كلمة السر ، استخدموا احد البرامج التي تستعمل الطرق اعلاه ، والدليل ان طريقة أخونا شفان اخذت اكثر من 21 ساعة من المحاولات ، وكذلك في اعتقادي بأنهم لم يتمكنوا من معرفة كلمة السر ، لأن أخونا سلمان كان مستخدم حروف عربية في كلمة السر ، بينما معظم برامج مقارنة كلمة السر لا تحتوي على حروف عربية او ان كلمة السر كانت اطول من 14 رقم وحرف: والسبب اني اكرر تسميتهم "برامج مقارنة" كلمة السر ، وذلك لأنها لا تستخرج كلمة السر مشفرة او بدون تشفير ، وإنما هي تحاول معرفة كلمة السر جعفر . . وهذه الطريقة الاكثر امانا لحفظ كلمة السر : . جعفر

السلام عليكم أخي الكريم بعد التجربة يشتغل (الكود 1 و الكود2) بامتياز و بدون مشاكل هذا هو المطلوب جزاك الله كل خير وبارك الله فيك وجعله في ميزان حسناتك ألف شكر

السلام عليكم ورحمة الله وبركاته أسعد الله أوقاتكم وبارك فيكم الملف المرفق يحتوي علي [ awsTimer ] وهو [ CLass Module ] والموضوع الأساسي [ awsStringBuilder] وهو [ CLass Module ] و موضوع فرعي [ awsSleepWait_MOD ] وهو [ Module ] و موضوع فرعي الباقي المواضيع الخاصة بهم بالمنتدي [ awsSleepWait_MOD ] - ببساطة وظيفته هي إيقاف عمل الكود لبعض الوقت ولسهولة الاستخدام تم إضافة وحدات للوقت (الوحدة الافتراضية الثواني) و يستخدم هكذا : - Call waitFor(500, wtMilliseconds) - Call waitFor(5, wtSeconds) - Call waitFor(1, wtMinutes) [ awsStringBuilder ] - وظيفة هذه الأداة هو تكوين النصوص الكبيرة بسرعة أكبر بكثير تصل إلي 98 % من الطريقة العادية لن أطيل فالحديث عنها لأنني وصلت إليها حديثاً ووجدت مصادر عده ولكن أغلبها قديم ولم أفحص الموضوع بعناية كبيرة لذا سأكتفي بمشاركة المصادر والوظيفة داخل الكود كما يوجد مثال Advanced_awsTimerTest ملحوظة المديول هام للوظيفة الأساسية لأنه مستخدم لبناء التقرير (النص والـ HTML) المصادر : https://nolongerset.com/string-concatenation-in-vba/ https://nolongerset.com/clsconcat/ https://github.com/joyfullservice/msaccess-vcs-addin/blob/main/Version%20Control.accda.src/modules/clsConcat.cls https://codereview.stackexchange.com/questions/67596/a-lightning-fast-stringbuilder/67600#67600 https://github.com/retailcoder/VBA-StringBuilder/blob/master/src/StringBuilder.cls https://www.vbforums.com/showthread.php?847365-VB6-StringBuilder-Fast-string-concatenation&s=43cda60b1b8cb40b2feaa60b32df951d https://github.com/dragokas/hijackthis/blob/devel/src/clsStringBuilder.cls نتائج التجربة : Normal Test Starts .... Normal String Length is : 944594 Normal Test Takes : 40.794s Normal Test End. SB Test Starts .... String Builder Length is : 894294 sb Way Length is : 894294 awsString builder Test Takes : 638ms sb Test End. AWS StringBuilder is 98.43% faster than the normal way. [ awsTimer ] - وهو موضوعنا الأساسي الأستخدام التقليدي : هو لحساب وقت أي عملية ويستخدم هكذا 1- تهية الـ Class module دخل الكود الخاص بك يتم بطريقتين أفضل الأولي Sub initialize_awsTimer_1() Dim sTimer As awsTimer Set sTimer = New awsTimer Set sTimer = Nothing End Sub Sub initialize_awsTimer_2() Dim sTimer As New awsTimer End Sub بعد ذلك لبدأ حساب الوقت sTimer.startTimer بعد بدأ الوقت يمكنك معرفة الوقت ميلي ثانية في أي لحظة من خلال Debug.Print .elapsedMS ويمكنك أيضاً الحصول علي الوقت منسق بالثواني والدقائق وهكذا من خلال Debug.Print .getFormattedTime(, tuSeconds) كما يمكن استخدام نفس الوظيفة لتنسق اي ميلي ثانية Debug.Print .getFormattedTime(6042, tuMilliseconds) Debug.Print .getFormattedTime(260, tuSeconds) Debug.Print .getFormattedTime(13.15, tuMinutes) ولإيقاف الوقت sTimer.stopTimer بعد إيقاف الوقت سيتوقف العد ولن تتمكن من بدأ او استكمل الحساب إلا بتهيئة جديدة الأستخدام المطور : مقدمة : يوجد لدي بعض الإجراءات التي تحتاج الي ما يقارب الـ 4 ساعات وهي تضم عمل العديد من الأكواد ولمتابعة عمل الأكواد وتسجيل الاحداث ووقت كل عملية والأخطأ والمعلومات كنت أقوم بذلك لكل منها ومن ثم تحليل المعلومات وذلك بشكل أساسي لتحسين وتسريع العملية وعليه فكرت في تطور مديول حساب الوقت ليتضمن الأتي - sTimer.pauseTimer وذلك لكي يتوقف عد الوقت ويستخدم عندما تريد إستثناء بعض الاجراءات مثال إذا اردت إستثناء وقت ظهور الرسالة للمستخدم وإنتظار إجابته عليها - sTimer.startTimer للبدأ والإستكمال بعد التوقف المؤقت - sTimer.addStep "Step1" وذلك لإضافة مرحلة وتستخدم للتحليل فيمكن حساب فرق الوقت بين المراحل كما فالتقرير النهائي يتم تحليل جميع المراحل - sTimer.getStepDiff "Step1", "Step2" وذلك لمعرفة الفرق بين مرحلتين بالميلي ثانية - sTimer.addInfo "UserName", "Ahmos" وذلك لإضافة معلومات كأسم الوظيفة التس ستبدأ او اسم المستخدم - sTimer.addError _ لإضافة الأخطاء أثناء عمل الأكواد "Source", _ مصدر الخطأ "error Number", _ رقم الخطأ "error Description" وصف الخطأ - sTimer.getAwsTimerInfo للحصول علي كافة البيانات - sTimer..exportLog "filePath", txt لتصدير النتائج يوجد نوعين (TXT and HTML) كما يتم التعامل مع 3 مسارات 1- يسمح لك إضافة مسار ملف كامل مع إسم الملف وسيتم التحقق من المسار وإذا امكن إنشاء الملف سيتم الكتابة بداخلة وإذا لم تدخل المسار سيتم اختيار مسار البرنامج وإذا نجح في إنشاء الملف بهذا المسار سيكتب بداخله وإذا فشل سيتم تصدير الملف لسطح المكتب هناك بعض التفاصيل البسيطة مثال للناتج Basic_awsTimerTest داخل مديول awsTimer_Test_MOD #-----------------------------------------------------------------------------------------------------------# ¦ AWS TIMER LOG ¦ ¦ Generated: 27/11/2024 05:52:41 PM ¦ #-----------------------------------------------------------------------------------------------------------# #-----------------------------------------------------------------------------------------------------------# ¦ COLLECTED INFORMATION ¦ #-----------------------------------------------------------------------------------------------------------¦ ¦Key ¦ Value ¦ #-----------------------------------------------------------------------------------------------------------¦ ¦initializedAt ¦ 27/11/2024 05:52:36 PM ¦ ¦currentPath ¦ D:\FOLDER\awsTimer\ ¦ ¦User ¦ UserName ¦ ¦startedAt ¦ 27/11/2024 05:52:36 PM ¦ ¦isoStart ¦ 2024-11-27T17:52:36.000 ¦ ¦startTime ¦ 0.0316 ¦ ¦pausedAt ¦ 27/11/2024 05:52:37 PM ¦ ¦pausedTime ¦ 1013.422 ¦ ¦pausedFormatted ¦ 1.013s ¦ ¦resumedAt ¦ 27/11/2024 05:52:38 PM ¦ ¦RunSub1 ¦ 1013.5207 ¦ ¦RunSub2 ¦ 2024.4509 ¦ ¦Step ¦ 3040.6271 ¦ ¦endTime ¦ 3047.2817 ¦ ¦stoppedAt ¦ 27/11/2024 05:52:40 PM ¦ ¦isoEnd ¦ 2024-11-27T17:52:40.000 ¦ ¦totalTime ¦ 3.047s ¦ ¦filePath ¦ D:\FOLDER\awsTimer\awsTimerLog_27.11.2024_05.52.41_PM.txt ¦ ¦folderPath ¦ D:\FOLDER\awsTimer\ ¦ ¦exportedAt ¦ 27/11/2024 05:52:41 PM ¦ ¦filePath_1 ¦ D:\FOLDER\awsTimer\awsTimerLog_27.11.2024_05.52.41_PM.html ¦ ¦folderPath_1 ¦ D:\FOLDER\awsTimer\ ¦ ¦exportedAt_1 ¦ 27/11/2024 05:52:41 PM ¦ #-----------------------------------------------------------------------------------------------------------# #-----------------------------------------------------------------------------------------------------------# ¦ STEP TIMING ANALYSIS ¦ #-----------------------------------------------------------------------------------------------------------¦ ¦Start Step ¦ End Step ¦ Duration ¦ #-----------------------------------------------------------------------------------------------------------¦ ¦startTime ¦ RunSub1 ¦ 1.013s ¦ ¦RunSub1 ¦ RunSub2 ¦ 1.010s ¦ ¦RunSub2 ¦ Step ¦ 1.016s ¦ ¦Step ¦ endTime ¦ 6ms ¦ ¦startTime ¦ endTime ¦ 3.047s ¦ #-----------------------------------------------------------------------------------------------------------# #-----------------------------------------------------------------------------------------------------------# ¦ ERRORS ENCOUNTERED ¦ #-----------------------------------------------------------------------------------------------------------¦ ¦Location ¦ Error Details ¦ #-----------------------------------------------------------------------------------------------------------¦ ¦Source ¦ 12345_Testing add an error._27/11/2024 05:52:41 PM ¦ #-----------------------------------------------------------------------------------------------------------# تعديلاتكم وإضافاتكم واستفساراتكم محل ترحيب. بالتوفيق! بالتوفيق awsTimerApi_V2_FN.zip

وعليكم السلام ورحمه الله وبركاته اتفضل لعله المطلوب Sub CustomSortByGender() Dim ws As Worksheet Dim lastRow As Long Dim maleList As Collection, femaleList As Collection Dim i As Long, rowIndex As Long Dim gender As String Dim maleRow As Long, femaleRow As Long ' تحديد الورقة النشطة (تأكد من تعديل الاسم إذا لزم الأمر) Set ws = ThisWorkbook.Sheets("Sheet1") ' تأكد من أن اسم الورقة صحيح ' تحديد آخر صف في العمود A (الذي يحتوي على بيانات) lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' إنشاء مجموعات لتخزين الذكور والإناث Set maleList = New Collection Set femaleList = New Collection ' تصنيف البيانات في العمود F إلى مجموعات الذكور والإناث For i = 2 To lastRow ' بدءًا من F2 gender = ws.Cells(i, "F").Value If gender = "ذكر" Then maleList.Add i ' إضافة رقم الصف إلى قائمة الذكور ElseIf gender = "أنثى" Then femaleList.Add i ' إضافة رقم الصف إلى قائمة الإناث End If Next i ' إعادة ترتيب البيانات في العمود F حسب التكرار المطلوب rowIndex = 2 ' نبدأ من F2 Do While maleList.Count > 0 Or femaleList.Count > 0 ' إضافة 2 ذكر If maleList.Count >= 2 Then maleRow = maleList(1) ws.Rows(maleRow).Copy ws.Rows(rowIndex).PasteSpecial Paste:=xlPasteAll maleList.Remove 1 maleList.Remove 1 rowIndex = rowIndex + 1 maleRow = maleList(1) ws.Rows(maleRow).Copy ws.Rows(rowIndex).PasteSpecial Paste:=xlPasteAll maleList.Remove 1 rowIndex = rowIndex + 1 ElseIf maleList.Count = 1 Then maleRow = maleList(1) ws.Rows(maleRow).Copy ws.Rows(rowIndex).PasteSpecial Paste:=xlPasteAll maleList.Remove 1 rowIndex = rowIndex + 1 End If ' إضافة 2 أنثى If femaleList.Count >= 2 Then femaleRow = femaleList(1) ws.Rows(femaleRow).Copy ws.Rows(rowIndex).PasteSpecial Paste:=xlPasteAll femaleList.Remove 1 femaleList.Remove 1 rowIndex = rowIndex + 1 femaleRow = femaleList(1) ws.Rows(femaleRow).Copy ws.Rows(rowIndex).PasteSpecial Paste:=xlPasteAll femaleList.Remove 1 rowIndex = rowIndex + 1 ElseIf femaleList.Count = 1 Then femaleRow = femaleList(1) ws.Rows(femaleRow).Copy ws.Rows(rowIndex).PasteSpecial Paste:=xlPasteAll femaleList.Remove 1 rowIndex = rowIndex + 1 End If Loop End Sub فرز حسب الجنس بشروط.xlsm فرز حسب الجنس بشروط.xlsm

وعليكم السلام ورحمه الله وبركاته راجع الموضوع ادناه لعله تجد ما يفيدك ويحل المشكله 1. اذهب الى Start ثم Settings 2 . اختر Control Panel 3. Regional And Language Options 4. من تبويب Advanced في خانة الاختيار اختر اللغة العربية 5. ثم OK ==================================== في محرر الاكواد من قائمة Tools ثم Option من تاب Editor Format ثم Font اختر نوع الخط هذا Courier New (Arabic)

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

وعليكم السلام ورحمة الله وبركاته .. جرب هذا الكود بعد التعديلات على زر الفلترة :- Private Sub Cm1_Click() Dim filterCondition As String Dim formattedDate As String filterCondition = "" If Not IsNull(Me.tx1) Then If filterCondition <> "" Then filterCondition = filterCondition & " AND " End If filterCondition = filterCondition & "nom = '" & Replace(Me.tx1, "'", "''") & "'" End If If Not IsNull(Me.tx2) Then If filterCondition <> "" Then filterCondition = filterCondition & " AND " End If formattedDate = "#" & Format(Me.tx2, "MM/DD/YYYY") & "#" filterCondition = filterCondition & "moveDate = " & formattedDate End If If filterCondition <> "" Then Me.Filter = filterCondition Me.FilterOn = True Else Me.FilterOn = False End If End Sub في الكود تم استخدام دالة Replace لتأمين النصوص في حقل tx1 ضد الأخطاء الناتجة عن علامات الاقتباس المفردة . وتنسيق التاريخ فقط . اما في الكود التالي ، فقط استخدمت تنسيق التاريخ ؛ وبدلاً من استخدام علامة الاقتباس المفردة ' لتطويق النصوص ، استخدمت علامتي اقتباس مزدوجتين """ لتجنب أي مشكلات ناتجة عن وجود اقتباسات مفردة داخل النصوص . Private Sub Cm1_Click() Dim filterCondition As String Dim formattedDate As String filterCondition = "" If Not IsNull(Me.tx1) Then If filterCondition <> "" Then filterCondition = filterCondition & " AND " End If filterCondition = filterCondition & "nom = """ & Me.tx1 & """" End If If Not IsNull(Me.tx2) Then If filterCondition <> "" Then filterCondition = filterCondition & " AND " End If formattedDate = "#" & Format(Me.tx2, "MM/DD/YYYY") & "#" filterCondition = filterCondition & "moveDate = " & formattedDate End If If filterCondition <> "" Then Me.Filter = filterCondition Me.FilterOn = True Else Me.FilterOn = False End If End Sub

عزيزي الأستاذ أبو مروان شكرا لحضرك للأهتمام بالموضوع لكن مش عارف أعمل ازاي باقي الكود من هنا إلى الأخر لأني ضعيف جدا في ال vba ومعرفش عنه إلا قشور البدايات .FitToPagesWide = 1 ' تأكد من طباعة الصفحة على عرض واحد .FitToPagesTall = False ' لا تحدد عدد الصفوف على الصفحة .LeftHeader = "صفحة " & pageNum ' عنوان الصفحة End With ' طباعة النطاق المحدد wsSource.PrintOut ' تحديث رقم الصفحة pageNum = pageNum + 1 Next i

نفع الله بك ، شكرا لك على ردك المتميز .. هذا ما كنت أحتاجه💞

تم عمل المطلوب قنم بوضع الاسم فى الفورم 2 textbox3 ثم قم باختيار من لوحة المفاتيح الامر F4 للانتقال بوضع الاسم الذى تم اختيارة فى listbox1 من خلال انتقال الاسهم من لوحة المفاتيح بعد الامر مباشرة F4 وعند اختيار الاسم المحدد قم باختيار الامر F2 للانتقال الى الفورم 1 وشكرا شاشة عميل بحث(1).xlsm

وعليكم السلام ورحمة الله وبركاته في نفس الصفحة في العمود E بمكن تغييره من الكود الكود Private Sub Worksheet_Change(ByVal Target As Range) Dim cell As Range Dim foundCell As Range Dim ws As Worksheet Dim rng As Range Dim lastRow As Long Dim deleteRow As Long Set ws = Me Set rng = ws.Range("A:A") If Not Intersect(Target, Me.Range("E:E")) Is Nothing Then Application.EnableEvents = False For Each cell In Intersect(Target, Me.Range("E:E")) If cell.Value <> "" Then Set foundCell = rng.Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole) If Not foundCell Is Nothing Then deleteRow = foundCell.Row foundCell.Delete xlShiftUp Else MsgBox "رقم العميل " & cell.Value & " غير موجود في قائمةالعملاء .", vbExclamation, "رقم غير موجود" End If End If Next cell lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row Set rng = ws.Range("A2:A" & lastRow) rng.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo Application.EnableEvents = True End If End Sub الملف officena.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب إستخدام إحدى الصيغ التالية =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

السلام عليكم و رحمة الله اليك الملف ملف1.xlsm