أ / محمد صالح

حسب فهمي للمطلوب أنك تريد تعديل جميع الصفوف التي يتساوى فيها عمود التاريخ مع التاريخ المكتوب في مربع النص مرة في شيت micro ومرة في شيت raw لذلك جرب تعديل كود زر الأمر إلى ما يلي: Private Sub CommandButton1_Click() Dim ws As Worksheet, we As Worksheet, lr As Long, iRow As Long, n As Long, k As Integer, m As Integer Set ws = Worksheets("micro") lr = ws.Cells(Rows.Count, 6).End(xlUp).row For n = 1 To lr If ws.Cells(n, 6).Value = CDate(Me.TextBox16.Value) Then ws.Cells(n, 13).Value = Me.TextBox10.Value ws.Cells(n, 14).Value = Me.TextBox11.Value ws.Cells(n, 15).Value = Me.TextBox12.Value ws.Cells(n, 16).Value = Me.TextBox13.Value ws.Cells(n, 17).Value = Me.TextBox14.Value ws.Cells(n, 18).Value = Me.TextBox15.Value For k = o To ListBox2.ListCount If ListBox2.Selected(k) = True Then ws.Cells(n, 11).Value = ListBox2.List(k, 0) Exit For On Error Resume Next End If Next k End If Next n Set we = Worksheets("Raw") iRow = we.Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).row For m = 1 To iRow If we.Cells(m, 6).Value = CDate(Me.TextBox16.Value) Then we.Cells(m, 16).Value = Me.TextBox10.Value we.Cells(m, 17).Value = Me.TextBox11.Value we.Cells(m, 18).Value = Me.TextBox12.Value we.Cells(m, 19).Value = Me.TextBox13.Value we.Cells(m, 20).Value = Me.TextBox14.Value we.Cells(m, 21).Value = Me.TextBox15.Value For k = o To ListBox2.ListCount If ListBox2.Selected(k) = True Then we.Cells(m, 11).Value = ListBox2.List(k, 0) Exit For On Error Resume Next End If Next k End If Next m End Sub لاحظ استعمال حلقة تكرارية لكل خلايا العمود F ورقمه 6 واستعمال المتغير N & M للتعبير عن رقم الصف الذي تساوت فيه القيم بالتوفيق

تقريبا الخطأ في أن الشرط في زر الحفظ والتعديل هو If C Like TextBox6.Value & "*" Then وهذا يعني أن الخلية تشبه الرقم وبعده أي رقم آخر * وربما يكون الصواب If c = Val(Me.TextBox6) Then وهو يعني تساوي الرقم مع الرقم المكتوب في مربع النص بالتوفيق

المطلوب غير واضح لي هل تقصد: إذا تساوت قيمة خلية في العمود f في الشيت micro يتم الترحيل في نفس الصف الذي تساوت فيه (طبعا في شيت micro) ولا يقوم بالترحيل في شيت raw وإذا تساوت قيمة خلية في العمود f في الشيت raw يتم الترحيل في نفس الصف الذي تساوت فيه ولا يقوم بالترحيل في شيت micro ؟؟؟

تفضل هذا ملفك بعد التعديل لاحظ استعمال المعادلة في جلب اسم مالك الشقة بدلا من كتابته واستعمال رقم الصف كبديل للترقيم وتغيير تنسيق التاريخ والأرقام بالتوفيق مصروفات وايرادات1.xlsm

الملف به كود يقوم بالترحيل إلى أول صف فارغ بعد المكتوب في شيت micro وشيت raw هل المطلوب تعديل الترحيل في شيت micro فقط إذا تساوى التاريخ في العمود f مع مربع نص التاريخ؟ مع الترحيل إلى آخر صف في شيت raw أم أنه لا يتم الترحيل في الاثنين إلا إذا تساوى التاريخ؟

لظهور الأقواس مضبوطة ينبغي التأكد من اتجاه المستند من اليمين لليسار وكذلك اتجاه الكتابة (إذا كانت لغة الكتابة عربية) وإذا أردت الاستبدال بعد ذلك فعليك بالآتي : استبدال القوس الأول إلى رمز غريب غير مستعمل في المستند مثل # مع تنفيذ استبدال الكل استبدال القوس الثاني إلى القوس الأول مع تنفيذ استبدال الكل استبدال الرمز الغريب إلى القوس الثاني مع استبدال الكل بالتوفيق

أخي الفاضل في حدث عند فتح المصنف راجع هذا السطر Select Case MBSerialNumber وهو لاختبار حالات المتغير MBSerialNumber الذي تنتجه الدالة المعرفة MBSerialNumber الموجودة في الموديول المنفصل فإذا كانت MBSerialNumber مثل واحدة من strMB1, strMB2, strMB3 لا يفعل شيئا ويستمر في فتح المصنف وإذا كانت غير ذلك يغلق المصنف مع حفظ التغييرات بالتوفيق

يمكنك استعمال هذا الكود في حدث عند الضغط على الزر 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 بالتوفيق

بالنسبة لموضوع التنسيق الشرطي يمكنك كتابة نفس الشروط التي استعملتها على العمود L الذي تظهر فيه حالة العقد

لا أدري أين المشكلة عندك ولكن إذا كنت تريد تطبيق ذلك على ملف آخر بامتداد 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 ثم تقوم بحفظ التغييرات وتغلق وتفتح الملف مرة أخرى بالتوفيق

كود جميل جدا ولكن أنا شخصيا لا أدخل أهتم بموضوع أو استفسار لا يرفق معه صاحبه مثالا على المطلوب مع توضيح المطلوب بمنتهى الدقة والتفاصيل والنتائج المتوقعة عيدكم مبارك

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

ملفك المرفق تم إضافة كود فتح المصنف المذكور في مشاركتك الأولى وتم حفظ الملف بامتداد xlsb وتم إغلاق الملف وفتحه فظهرت الرسالة وتم إغلاق الملف حسب الكود

حسب فهمي للمطلوب جرب هذه المعادلة في الخلية L26 =IFERROR(IF(AND(M26<>"",M26<I26),"سداد مبكر",IF(TODAY()=I26,"العقد انتهى اليوم",IF(TODAY()>I26,"العقـد منتهى",IF(TODAY()<H26,"لم يتم تداولة","العقـد سارى")))),"") تم تعديل الشرط الأول إلى ألا تكون الخلية فارغة وتكون أقل من تاريخ نهاية العقد

يمكنك استعمال هذه الدالة المعرفة 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 بالتوفيق

الكود يعمل بصورة طبيعية جدا على ملف xlsb رجاء توضيح ما يحدث معك ورقم الخطأ وسطر الخطأ في الكود

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

جميل جدا عيدكم مبارك

في مثل هذه الحالات يمكنك تسجيـل ماكرو وتفعل ما تريد وستحصل على الكود وتعدله كما تشاء

جميعا بإذن الله بالتوفيق

الصواب في الفرز على الصف 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 عيدكم مبارك

جرب الصف 11 في تعريف rg لأن المعدل العام خلية مدمجة وتأكد من كتابتها في الخلية بهذه الصورة فربما يكون بعدها مسافة زائدة

جميل جدا إن تقوم بتسجيل ماكرو لما تريده وتحاول دمجه في الكود الاصلي واقترح عليك حتى يتم التنفيذ على الملف المفتوح إن تضيف objBook.Sheets("data") قبل كلمة range او كلمة autofilter او كلمة rows عيدكم مبارك

تستعمل هذه الدوال مثل cells و offset و rows وغيرها الكثير في التحكم في الوصول لخلايا معينة حسب احتياجك وللعلم اي ثوابت يمكن استبدالها بقيم مثل sheets("mas") يمكن استبدالها ب sheets(1) إذا كان ترتيب شيت ماس هو الأول وهكذا

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