محمد هشام.

العفو اخي الفاضل لقد حاولت تبسيط الكود الاول ليتم فهمه ربما تحتاج يوما ما للتعديل تفضل اخي اليك كود اخر يقوم بنفس المهمة لاكن حاول تجنب وضع علامة / بين الكلمات يمكنك استبدالها ب علامة (-) مثلا وسوف يشتغل معك الكود بكفاءة عالية بالتوفيق 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

تم التعديل في الملف المرفق في المشاركة رقم 1 واليك كود اخر يمكنك التعديل عليه ليتوافق مع ملفك الاصلي Sub copy_columns_paste() Dim lr As Integer, MH As Integer, sh1 As Worksheet, sh2 As Worksheet, i As Long Sheet2.Activate 'افراغ البيانات القديمة Range("d10", Range("F" & Rows.Count).End(4)).ClearContents Range("L10", Range("L" & Rows.Count).End(4)).ClearContents Range("N10", Range("N" & Rows.Count).End(4)).ClearContents Set sh1 = Sheet1 Set sh2 = Sheet2 lr = sh1.Cells(Rows.Count, 4).End(xlUp).Row For i = 10 To lr ' تحديد صف بداية النسخ MH = sh2.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Row 'العمود المراد ترحيله من شيت 1 _____ العمود المرحل اليه في شيت 2 sh2.Cells(MH, 4) = sh1.Cells(i, 4) sh2.Cells(MH, 5) = sh1.Cells(i, 5) sh2.Cells(MH, 6) = sh1.Cells(i, 6) sh2.Cells(MH, 12) = sh1.Cells(i, 9) sh2.Cells(MH, 14) = sh1.Cells(i, 12) Next i End Sub

تم تعديل الملف بداخله شرح مبسط @2saad

وغليكم السلام ورحمة الله تعالى وبركاته تفضل استاد سغد Sub Test() Dim lr As Long Application.ScreenUpdating = False With Sheet1 lr = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row .Range(.Cells(10, "D"), .Cells(lr, "F")).Copy Sheet2.Cells(10, "D") .Range(.Cells(10, "I"), .Cells(lr, "I")).Copy Sheet2.Cells(10, "L") .Range(.Cells(10, "L"), .Cells(lr, "L")).Copy Sheet2.Cells(10, "N") End With Application.ScreenUpdating = True End Sub W_S.xlsm

تفضل اخي Sheet_name.xlsb

السلام عليكم ورحمة الله تعالى وبركاته استاد فوزي لم استوعب طلبك حتى رايت حلول الاساتدة جزاهم الله خيرا بعد ادن الاساتده طبعا اليك حل اخر توزيع الايام مع الشهور4.xlsm

اخي لقد تمت الاجابة عن طلبك من قبل الاساتدة اليك حل اخر ربما هدا طلبك Dim Last As Long Last = Worksheets(Mydate).UsedRange.Rows.Count Worksheets(Mydate).Range("A1:f" & Last).AdvancedFilter xlFilterCopy _ , Worksheets(MyFind).Range("K2:L3"), Worksheets(MyFind).Range("A5:f5"), False Dim lr1 As Long lr1 = Sheet2.Range("G" & Rows.Count).End(xlUp).Row + 1 Range("G6:G" & lr1).Clear lr2 = Cells(Rows.Count, "E").End(xlUp).Row + 1 For i = 6 To lr2 If Cells(i, "F") = "" Then Cells(i, "F").Offset(-1, 1).Select ActiveCell = Evaluate("SUM(d6:d" & lr2 & "*E6:E" & lr2 & ")") Exit For End If Next End Sub OFFICENA 2024.xlsm

بعني انت الدي وضعت هدا الكود Private Sub TextBox1_Change() If Sheet1.TextBox1.Value <> "" Then Sheet1.ListBox1.Visible = True Else Sheet1.ListBox1.Visible = False End If End Sub

تفضل اخي قد تم تعديل كود الطباعة في الملف المرفق للتجربة ليتم تنسيق حجم الفواتير تلقائيا A4 فاتورة_Mh5-user form.xlsm