محمد هشام.

الملف يشتغل عندي بكفاءة اخي الكريم . https://streamable.com/3mbrm0 تم اعادة رفع الملف مرة اخرى للتجربة فكرة 2.xlsm

ليس هناك أي خطوات اخي الفاضل يشتغل تلقائيا عند ادخال القيم في الخلية E2 حاول غلق الملف وإعادة تشغيله مرة أخرى

وعليكم السلام ورحمة الله تعالى وبركاته تقضل استاد فوزي ربما هدا ما تقصد Const MyWidth As Single = 80 Const MyHight As Single = 20 Private Sub TEST1() Dim WS As Range Dim Lf As Double, Tp As Double Dim ContColmn As Integer, r As Integer, c As Integer Set WS = Range("A3:I17") ContColmn = WS.Columns.Count For r = 1 To WS.Rows.Count l = 0 Lf = Me.Frame1.Width - 100 For c = 1 To ContColmn Lf = Lf - WS.Columns(c).Width With Me.Frame1.Controls.Add("Forms.Label.1") .BorderStyle = 1 .Move Lf, Tp, MyWidth, MyHight .Width = WS.Columns(c).Width Call TEST(.Name, WS.Cells(r, c)) End With Next Tp = Tp + MyHight c = 0 Next Set X = Nothing End Sub Private Sub TEST(iName As String, MyCel As Range) With Me.Controls(iName) .BackColor = MyCel.Interior.Color .Caption = MyCel.Text .TextAlign = 2 With .Font .Name = MyCel.Font.Name .Bold = True .Size = MyCel.Font.Size End With End With End Sub Private Sub UserForm_Initialize() Me.Frame1.SpecialEffect = 0 TEST1 End Sub عرض النتائج فى الفورم_1.xlsm

تفضل اخي تم تعويض زر اظهار الفورم بدوبل كليك على الصف الأول (عناوين الأعمدة) مع امكانية اضافة صورة حتى لو البيانات غير مكتملة. طلب وتعديل4.xlsm

وفي حالة وضع شرط لو الخلية فارغة يمكنك جعل الكود كالتالي With ws.Range("c2:c" & LR) .Formula = "=IF(B2="""","""",VLOOKUP(""*""&B2&""*"",sheet1!A:E,1,0))" .Value = .Value

تفضل اخي هذا مثال لطلبك Sub TEST_mh5() Dim ws As Worksheet Dim LR As Long Set ws = Worksheets("sheet2") Application.ScreenUpdating = False LR = ws.Range("B" & Rows.Count).End(xlUp).Row With ws.Range("c2:c" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,1,0)" .Value = .Value With ws.Range("d2:d" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,2,0)" .Value = .Value With ws.Range("E2:E" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,3,0)" .Value = .Value With ws.Range("F2:F" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,4,0)" .Value = .Value With ws.Range("G2:G" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,5,0)" .Value = .Value End With End With End With End With End With End Sub جلب البيانات 2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته كنت في انتظار رفع ملف للتطبيق عليه . بما انها مجرد فكرة وتريد حلها تفضل اخي الكريم يمكنك فعل دالك بواسطة الكود التالي لاستخراج مجموع القيم السالبة والموجبة وكدالك مجموع القيم المدخلة مع اضافة امكانية ظبط قيمة التغيير التي نعتمد عليها في الحساب في مثالنا هدا قد تم تنفيد طلبك مثلا اقول اذا كان التغيير هو 3 نقاط فا اكثر نبداء بالحساب ولكن اذا اكان التغيير اقل من 3 نقاط تجاهل الموضوع، وكان شيئا لم يحدث . ويمكنك ظبط القيمة كما تشاء من داخل الكود Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$E$2" Then ' هنا ممكن ضبط قيمة اقل تغيير نعتمد عليه في الحساب' If Abs(Tmp - Target) < 3 Then Exit Sub Application.EnableEvents = False If Target < Tmp Then [m2] = [m2] + Tmp - Target 'عدد الاختلافات بالسالب' Else If Tmp <> 0 Then [g2] = [g2] + Target - Tmp 'عدد الاختلافات بالموجب End If Tmp = Target Application.EnableEvents = True End If If Target.Address = "$E$2" Then [b2] = [b2] + Target 'مجموع القيم المدخلة End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = "$E$2" Then Tmp = Target End Sub في حالة عدم الرغبة في وضع شرط اقل قيمة يمكنك استخدام الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = Me.[e2].Address Then Ecart = Target.Value - Me.[OldVal] Me.Names("OldVal").RefersTo = 0 + Target.Value Range("E2").Select Select Case Ecart Case Is > 0 Me.[g2] = Me.[g2] + Ecart Case Is < 0 Me.[m2] = Me.[m2] - Ecart Case 0 Range("b2").Value = Range("b2").Value + Target.Value End Select End If If Target.Address = "$E$2" Then [b2] = [b2] + Target End If End Sub واليك اخي الكريم الملف تم تطبيق الفكرة عليه للتجربة فكرة.xlsm

العفو اخي الكريم .بالتوفيق

العفو اخي الفاضل لقد حاولت تبسيط الكود الاول ليتم فهمه ربما تحتاج يوما ما للتعديل تفضل اخي اليك كود اخر يقوم بنفس المهمة لاكن حاول تجنب وضع علامة / بين الكلمات يمكنك استبدالها ب علامة (-) مثلا وسوف يشتغل معك الكود بكفاءة عالية بالتوفيق Sub Test_MH3() Dim a, b Dim I As Long, II As Long, LR As Long Dim j As Integer Dim ObjDic As Object Set ObjDic = CreateObject("Scripting.Dictionary") Dim K, T LR = Cells(Rows.Count, "A").End(3).Row a = Range("A2:D" & LR) For I = LBound(a, 1) To UBound(a, 1) ObjDic(a(I, 1)) = a(I, 2) & "/" & a(I, 3) & "/" & a(I, 4) Next I LR = Cells(Rows.Count, "e").End(3).Row b = Range("E2:E" & LR) ReDim Preserve b(LBound(b, 1) To UBound(b, 1), 1 To 5) For I = LBound(b, 1) To UBound(b, 1) For Each K In ObjDic.keys If K Like "*" & b(I, 1) & "*" Then T = Split(ObjDic(K), "/") b(I, 1) = K For II = 0 To UBound(T, 1) b(I, 2 + II) = T(II) Next II Exit For End If Next K Next I Cells(2, "F").Resize(UBound(b, 1), 4) = b End Sub نسخة من نسخة officene _3.xlsm

لا يمكنني تخمين موضع الحقول التي سيتم اظافتها يمكنك تعديله بنفس الطريقة عند اظافة حقول جديدة Sub TEST_MH2() Dim MT As Worksheet Dim lr As Long Set MT = Worksheets("sheet4") Application.ScreenUpdating = False lr = MT.Range("A" & Rows.Count).End(xlUp).Row MT.Range("F2:i" & lr).ClearContents With MT.Range("F2:F" & lr) .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,1,0)" .Value = .Value With MT.Range("G2:G" & lr) .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,2,0)" .Value = .Value With MT.Range("H2:H" & lr) .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,3,0)" .Value = .Value With MT.Range("I2:I" & lr) .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,4,0)" .Value = .Value End With End With End With End With Application.ScreenUpdating = True End Sub نسخة من نسخة officene _2.xlsm

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

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي نسخة من officene.xlsm

نعم ده مجرد إضافة فقط لو حبيت تستخدمها

طبعا لا حاول تثبيث نسخة 2021 ستمكنك من للاستفادة من عدة دوال غير موجودة في النسخ السابقة صراحة لا أعلم هل قانون المنتدى يسمح بوضع الروابط داخل المشاركة ام لا على العموم هذا رابط لنسخة 2021 قد سبق وأن رفعتها لأحد الأعضاء على المنتدى https://www.mediafire.com/file/rgd5dqaiagdhckm/Office_2021-M__Hicham.zip/file

هدا ما فهمت من الشرح داخل الملف حساب عدد ايام كل شهر من سنة 2025 كمثال ماهي النتيجة المتوقعة غير النتيجة الظاهرة تحت

وعليكم السلام ورحة الله تعالى وبركاته تفضل جرب اخي تم الاعتماد على اعمدة مساعدة لفرز الشهور التي لم تبلغ بعد 28 يوما بمعنى عند التحقق من بلوغ الشهر 28 يوما لما فوق تقوم المعادلة بحساب عدد ايام الشهر مثال 28*28 اما في حالة عدم بلوغه 28 يتم احتساب قيمة الخلية فقط اضافة للشهور المكتملة . حساب المدد.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاخوة الكرام بعض التعديلات البسيطة ربما تلبي المطلوب طلب وتعديل3.xlsm

تفضل اخي 2022-2021 INVOICE.xlsx

اخي يتم إظهارحالة الدفع بشرط وجودها في نفس السنة ونفس الشهر. قم بالتحقق من تاريخ دفع الفاتورة في عمود L رقم الفاتورة التي قمت بتحديدها موجود في شيت 2022 شهر 8

وعليكم السلام ورحمة الله تعالى وبركاته العد.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي 2022-2021 INVOICE.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته Private Sub TextBox2_Change() On Error Resume Next Diff_n = DateDiff("n", TextBox1, TextBox2) Diff_h = Diff_n \ 60 Diff_m = Diff_n - (Diff_h * 60) TextBox3 = Format(Diff_h, "00") & ":" & Format(Diff_m, "00") On Error GoTo 0 End Sub test.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Private Sub UserForm_Initialize() Me.ListBox1.List = [liste].Value End Sub ''''''''''''''''''''''''''''''''''''''''' Private Sub TxtSearch_Change() Me.ListBox1.Clear i = 0 For Each c In Application.Index([liste], , 1) If UCase(c) Like UCase(Me.TxtSearch) & "*" Then Me.ListBox1.AddItem Me.ListBox1.List(i, 0) = c.Value i = i + 1 End If Next c End Sub اسماء العاملين.xlsm

طلبك غير منطقي هو الواحد لما هيدخل الباسوورد هيكون عرفه وفي نفس الوقت لا تريد اظهاره له ؟ @Osama-2020

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي جرب مع مثال بسيط لطلبك Sub Unlock1() Dim inpu1 As String, inpu2 As String ' يمكنك وضع الباسوورد في اي شيت من اختيارك مع تحديد اسمه . وخلية الرقم السري داخل الكود كما في المثال '(A1) وضع رقم الباسوورد في الخلية inpu2 = Sheets("data").Range("A1").Value inpu1 = Application.InputBox("Please Enter Your Password") If inpu1 = inpu2 Then Sheets("Renewal").Activate End Sub ''''''''''''''''''''''''''''''''''''''''''''''' Sub Unlock2() Dim inpu1 As String, inpu2 As String 'وضع الباسوورد في شيت مخفي '(b10) وضع الرقم السري في الخلية inpu2 = Sheets("sheet2").Range("b10").Value inpu1 = Application.InputBox("Please Enter Your Password") If inpu1 = inpu2 Then Sheets("Renewal").Activate End Sub Osama-Test.xlsm