أ / محمد صالح

لا أدري أين المشكلة عندك
ولكن
إذا كنت تريد تطبيق ذلك على ملف آخر بامتداد xlsb
أولا تفتح شاشة الفيجوال بيسك داخل اكسل
ثم تضيف موديول جديد وتلصق فيه الكود الذي يتحقق من رقم الماذربورد
Function MBSerialNumber(Optional strComputer As String = ".") As String Dim v, vName, vUUID With GetObject("winmgmts:\\" & strComputer & "\root\cimv2") For Each v In .ExecQuery("SELECT * FROM Win32_ComputerSystemProduct", , 48) vName = v.Name: vUUID = v.UUID Next v End With MBSerialNumber = vName & ", " & vUUID End Function ثم تضغط دبل كلك على thisworkbook وتلصق هذا الكود في حدث عند فتح الملف
Private Sub Workbook_Open() Dim strMB1 As String, strMB2 As String, strMB3 As String 'Put Your MotherBoard Serial strMB1 = "HP ProDesk 490 G1 MT, FF004080-EE39-11E3-BFF8-A0D3C13F35B2" strMB2 = "HP Compaq 8500 Elite SFF PC, BFDEF800-AF9A-11E0-0000-2C27D742989F" strMB3 = "HP Compaq 8500 Elite SFF PC, BFDEF800-AF9A-11E0-0000-2C27D742989F" Select Case MBSerialNumber Case strMB1, strMB2, strMB3 Exit Sub Case Else MsgBox ("Data Security Failure. This Workbook Will Close") ActiveWorkbook.Close 1 End Select End Sub ثم تقوم بحفظ التغييرات وتغلق وتفتح الملف مرة أخرى
بالتوفيق

يمكنك استعمال هذا الكود في حدث عند الضغط على الزر
Private Sub CommandButton1_Click() Dim iRow As Long, Lastrow As Long, i As Long With ورقة1 Lastrow = .Cells(.Rows.Count, 7).End(xlUp).Row For r = 3 To Lastrow If .Cells(r, 7) = TextBox1.Value Then iRow = .Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Row .Cells(iRow, 3).Value = Me.TextBox1.Value .Cells(iRow, 4).Value = Me.TextBox2.Value MsgBox " لقد تم الترحيل بنجاح ", vbExclamation + vbMsgBoxRight, "تم الترحيل " GoTo 1 End If Next End With MsgBox "لايوجد هذا الاسمً ", vbInformation + vbMsgBoxRight, "تنبيه" 1: TextBox1.Value = "" TextBox2.Value = "" TextBox1.SetFocus End Sub بالتوفيق

إذا كنت تقصد المعادلة في الخلية M18
فهذه تأتي بمعادلة البحث المستعملة في الشيت
=VLOOKUP(D3,B26:L61,11,0) لأن خلية حالة العقد في الجدول بالأسفل تعتمد على خلية أخرى هي خلية سداد مبكر بتاريخ
بالتوفيق

يمكنك استعمال هذه الدالة المعرفة
Function checknum(rng As Range) For n = 1 To 100 If Sqr(rng * n + rng.Offset(0, 1)) = rng.Offset(0, 2) Then checknum = rng.Offset(0, 2): Exit Function End If Next n checknum = 0 End Function ولاستدعاء الدالة نضع في الخلية F2
=checknum(A2) ولا تنس حفظ الملف بصيغة تدعم الماكرو مثل xlsb
بالتوفيق

جرب هذه المعادلات
خساب الاقدمية.xls

حسب فهمي للمطلوب يمكنك استعمال هذا الكود
Private Sub CommandButton5_Click() If ActiveSheet.Name <> "data" Then Dim wslr As Integer, counter As Integer, ws As Worksheet Set ws = ThisWorkbook.Worksheets("data") wslr = ws.Cells(Rows.Count, 1).End(xlUp).Row For counter = 1 To wslr If ws.Cells(counter, 2) = TextBox1.Value Then ws.Cells(counter, 2).EntireRow.Delete counter = counter - 1 End If Next MsgBox "تم حذف الاسم" End If End Sub  

حسب فهمي للمطلوب يمكنك استعمال هذا الكود
Private Sub CommandButton5_Click() If ActiveSheet.Name <> "data" Then Dim wslr As Integer, counter As Integer, ws As Worksheet Set ws = ThisWorkbook.Worksheets("data") wslr = ws.Cells(Rows.Count, 1).End(xlUp).Row For counter = 1 To wslr If ws.Cells(counter, 2) = TextBox1.Value Then ws.Cells(counter, 2).EntireRow.Delete counter = counter - 1 End If Next MsgBox "تم حذف الاسم" End If End Sub  

حسب فهمي للمطلوب يمكنك استعمال هذا الكود
Private Sub CommandButton5_Click() If ActiveSheet.Name <> "data" Then Dim wslr As Integer, counter As Integer, ws As Worksheet Set ws = ThisWorkbook.Worksheets("data") wslr = ws.Cells(Rows.Count, 1).End(xlUp).Row For counter = 1 To wslr If ws.Cells(counter, 2) = TextBox1.Value Then ws.Cells(counter, 2).EntireRow.Delete counter = counter - 1 End If Next MsgBox "تم حذف الاسم" End If End Sub  

الصواب في الفرز على الصف 11 ولكن
المشكلة الحقيقية في تنفيذ الفرز في ملفك هو دمج الخلايا في العناوين
فأصبحت الخلايا b11 , c11, d11, j11, k11 فارغة مما يجعل عملية الفرز غير دقيقة
ولذا أضفت كود فك الدمج لهذه الخلايا قبل كود الفرز
Sub insertformula3() Application.ScreenUpdating = 0 Dim strfile As String, col As String, col1 As String, objBook As Workbook, lr As Long, c As Integer strfile = Dir(ThisWorkbook.Path & "\*.xlsx", vbNormal) While strfile <> "" Set objBook = Workbooks.Open(ThisWorkbook.Path & "\" & strfile) c = objBook.Sheets("data").Range("b10").CurrentRegion.Columns.Count col = IIf(c = 10, "j", "l") col1 = IIf(c = 10, "k", "m") lr = objBook.Sheets("data").Range(col & Rows.Count).End(xlUp).Row objBook.Sheets("data").Range(col1 & "12").Formula = "=IF(Or(" & col & "12<5," & col & "12=""ن.م.ر""),""يكرر"",""ينتقل"")" objBook.Sheets("data").Range(col1 & "12").AutoFill Destination:=objBook.Sheets("data").Range(col1 & "12:" & col1 & lr) If objBook.Sheets("data").AutoFilterMode Then Selection.AutoFilter objBook.Sheets("data").Range("b10:b11").UnMerge objBook.Sheets("data").Range("b11").Value = "رقم التلميذ" objBook.Sheets("data").Range("b10").ClearContents objBook.Sheets("data").Range("c10:c11").UnMerge objBook.Sheets("data").Range("c11").Value = "الاسم والنسب" objBook.Sheets("data").Range("c10").ClearContents objBook.Sheets("data").Range("d10:d11").UnMerge objBook.Sheets("data").Range("d11").Value = "النوع" objBook.Sheets("data").Range("d10").ClearContents objBook.Sheets("data").Range(col & "10:" & col & "11").UnMerge objBook.Sheets("data").Range(col & "11").Value = "المعدل العام" objBook.Sheets("data").Range(col & "10").ClearContents objBook.Sheets("data").Range(col1 & "10:" & col1 & "11").UnMerge objBook.Sheets("data").Range(col1 & "11").Value = "قرار المجلس" objBook.Sheets("data").Range(col1 & "10").ClearContents objBook.Sheets("data").Rows("11:11").AutoFilter objBook.Sheets("Data").AutoFilter.Sort.SortFields.Clear objBook.Sheets("Data").AutoFilter.Sort.SortFields.Add2 Key:=Range(IIf(c = 10, "j11", "l11")), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal With objBook.Sheets("Data").AutoFilter.Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With objBook.Sheets("data").Range("b12").Select objBook.Close 1 strfile = Dir() Wend Application.ScreenUpdating = 1 MsgBox "هشام:تمت عملية إضافة القرار" End Sub عيدكم مبارك

فعلا رقم 3 بديل Xlup
.End(Direction) xlToLeft = 1 xlToRight = 2 xlUp = 3 xlDown = 4 أما عن رقم 2 فهو بديل من استعمال cells مرة أخرى ولكن على اعتبار أن آخر خلية في الصف هي 1,1
بمعنى
جرب هذا الكود
Worksheets(WS.Name).Cells(Rows.Count, 1).End(3).cells(2,1) ستجده يعطي نفس النتيجة
وهي الانتقال للصف التالي 2 باعتبار الصف الحالي 1 والعمود الحالي 1
بالتوفيق

نعم اتضح عدم تجاوز الأشهر المسددة مدة العقد
جرب كتابة هذه المعادلة في الأشهر المسددة
=IF(DATEDIF(M14,NOW(),"m")+1>L14,L14,DATEDIF(M14,NOW(),"m")+1) ومعناها إذا كان ناتج المعادلة أكبر من عدد شهور العقد فتكون قيمة الخلية عدد شهور العقد فقط ولا يزيد
بالتوفيق

شكرا لكلماتك الطيبة
لكن هذه أصول برمجية تعلمناها جعل التاريخ حقل منفصل حتى يسهل تغييره
لأنك بعد هذه الفترة
إذا أردت تعديل تاريخ النهاية تحتاج تغيير الخلية c1 فقط
أما إذا كتبت التاريخ في المعادلة فستحتاج تغيير جميع الخلايا التي فيها المعادلة
ورغم ذلك يمكنك استعمال الدالة date كما يلي
=IF(A2<=DATE(2021,6,30),"انتهت صلاحية المنتج","المنتج صالح للتداول") عيدكم مبارك

ربما تفيدك هذه النتائج
https://www.officena.net/ib/search/?q=يوزرفورم بحث&updated_after=any&sortby=relevancy&search_and_or=and
 

يمكنك استعمال هذا الإجراء
التنفيذ بعد تحديد الخلية المكتوب فيها كود الموظف
Sub masFillDays() month_days = Day(DateSerial(Year([d1]), Month([d1]) + 1, 1) - 1) For n = 1 To month_days ActiveCell.Offset(n - 1, -1).Value = n ActiveCell.Offset(n - 1, 0).Value = ActiveCell.Value ActiveCell.Offset(n - 1, 6).Value = DateSerial(Year([d1]), Month([d1]), n) Next n MsgBox "done" End Sub ولا تنس تغيير امتداد الملف لصيغة تدعم الماكرة مثل xlsb
بالتوفيق

ملفك بعد التعديل السابق يعمل بكفاءة عالية حتى وإن وصلت الموديلات إلى 15000
ولكن هذا كود نسخ القيم الفريدة
Sub mas_copyUnique() Sheets("الوارد").Range("D2:D15000").AdvancedFilter 2, , Sheets("المخزون").Range("B2"), 1 MsgBox "Done" End Sub للعلم ستحتاج إلى تنفيذ الكود بعد كل إضافة لموديل جديد فريد
وهذه ميزة المعادلات عن الأكواد
بالتوفيق

أخي الكريم
الفاصلة تختلف من جهاز لآخر حسب إعدادات النظام
وتقريبا في حالتك الفاصلة هي الفاصلة المنقوطة وليست الفاصلة فقط
لذلك يمكنك استعمال الفاصلة المنقوطة في المعادلة بدلا من الفاصلة
لتصبح
=IFERROR(INDEX(الرصيد!$J:$J;MATCH(C2;الرصيد!$C:$C;0));"") وهكذا في أي معادلة تنسخها من المنتدى تجعلها أولا موافقة لنظام جهازك
بالتوفيق

ربما تكون المشكلة في تنسيقات النظام حيث من المعروف أن الماك يجعل العلامة العشرية فاصلة وليست نقطة و‏لإجراء تغييرات في تفضيلات النظام:‏ ‏تأكد من إغلاق Excel تماما‏ ‏اختر شعار Apple في الزاوية العلوية اليسرى من الشاشة واختر ‏‏تفضيلات النظام‏ System Preferences ‏اختر ‏‏اللغة والنص‏  Language & Text ‏تحديد علامة التبويب ‏‏تنسيقات‏ Formats  ‏تغيير ‏‏المنطقة‏‏ إلى ‏‏الولايات المتحدة الأمريكية‏ ‏إغلاق تفضيلات النظام واختبر داخل Excel‏ ‏بمجرد تعيين تفضيلات النظام لنمط العملة، يجب إنهاء Excel وإعادة تشغيله حتى يصبح التحديد نافذ المفعول.‏   ولتغيير فاصل الآلاف والعلامة العشرية System Preference>Language & Region>Advanced>General (grouping (,) decimal (.) ) شاهد هذا إن شاء الله يفيدك بالتوفيق

تم استعمال دوال أخرى في البحث أدق وهي index & match
تفضل ملفك بعد التعديل
عميل2.xlsx

إذا كان الحل هو دمج المراسلات والمشكلة هي عرض أكثر من صف في نفس الصفحة
فبإذن الله يفيدك هذا الموضوع
 

يمكنك استعمال هذا الإجراء وربطه مع أي زر
ThisWorkbook.Close 1 بالتوفيق

بالنسبة للمطلوب الأول
يمكنك استعمال هذا الإجراء
Sub tar7eel() For n = 3 To 51 Sheets("خصم").Range("c" & n - 2).Value = Sheets("حساب").Range("f" & n).Value Next n MsgBox "Done" End Sub وبالنسبة للمطلوب الثاني
في صفحة حساب يوجد في العمود f معادلة وإذا تم الترحيل من صفحة خصم إليها سيتم حذف المعادلة

لا أدري ما الجزء الذي تريد عمل فورم له
على العموم
خطوات إضافة فورم للملف:
* اضغط ALT+F11 لفتح شاشة الفيجوال بيسك
* من قائمة INSERT اختر userform
* أضف أدوات التحكم المناسبة لاحتياجاتك من تسميات labels أو مربعات نصوص textbox أو أزرار button
بالتوفيق

العمود G والعمود I ضمن المدى الذي إذا تغير يغير المعادلات فتبقى في سلسلة لا نهاية من تنفيذ الكود
وحتى تستثني العمود G والعمود I يجب أن تضيف شرط ألا يكون العمود 7 أو 9
If Target.Row > 5 And Target.Column < 11 And Target.Column <> 6 And Target.Column <> 7 And Target.Column <> 9 Then بالتوفيق

شكرا لكلماتك الطيبة
في أول مشاركة
وفي آخر مشاركة
؟؟؟؟؟
إذا كنت تقصد جلب التاريخ من الشيت وترحيل التاريخ إلى الشيت فأهم شيء هو تحويل قيمة الخلية أو مربع النص إلى تاريخ بـ CDATE طبعا مع تطابق تنسيق التاريخ في الخلية ومربع النص
وإليك مثالا عن إدخال التاريخ في النموذج وترحيله وجلبه من الشيت
إن شاء الله يفيدك
date in form.xlsb

لا أعتقد إمكانية وضع 2 قاعدة للتحقق من الصحة
ولكن
يمكن التحايل على ذلك بالكود التالي
في حدث عند تغيير محتويات الشيت sheet1
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 5 Then If Target.Offset(0, 1) = "" Then Target.Value = Null End If If Target.Column = 6 Then Target.Offset(0, -1).Select With Selection.Validation .Delete .Add Type:=xlValidateList, Formula1:="=$A$1:$A$3" End With End If End Sub مع تغيير امتداد الملف لصيغة تدعم الماكرو مثل xlsb
بالتوفيق