محمد هشام.

السلام عليكم ورحمة الله تعالى وبركاته اولا اسف على التاخير لم استطيع امس تعديل المعادلات بسبب ضيق الوقت وعدم توضيحك المسبق لامكانية زيادة اوراق العمل تفضل اخي تم وضع المعادلات لغاية 350 صف قابل للزيادة مع التعرف تلقائيا على اوراق العمل المضافة اما في حالة كانت عندك رغبة بالبحث فقط بالقيمة الموجودة في الخانة B4 يمكنك استبدال الكود الموجود في حدث ورقة toutal بهدا الكود رغم اني ارى ان المعادلات افضل بسبب انها تتيح لك رؤية جميع النتائج الموجودة في اوراق العمل كلها في نفس الوقت Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet If Target.Address = "$B$4" Then Me.Cells(4, 3).Resize(, 12).ClearContents If Not IsEmpty(Target) Then Set ws = Worksheets(Target.Value) Select Case ws.Name Case "toutal": Case Else: With Me .Range("C4") = ws.Range("B11") .Range("D4") = ws.Range("B6") .Range("E4") = ws.Range("B8") .Range("F4") = ws.Range("M6") .Range("G4") = ws.Range("B12") .Range("H4") = ws.Range("B13") .Range("I4") = ws.Range("B17") .Range("J4") = ws.Range("K47") .Range("K4") = ws.Range("L47") .Range("L4") = ws.Range("M47") .Range("M4") = ws.Range("N47") .Range("N4") = ws.Range("C81") End With End Select End If End If End If If Target.Count > 1 Or Target.Row <= 2 Then Exit Sub If Target.Column = 2 And Target.Value <> "" And Not (sheetExists(Target.Value)) Then Call newsh(Target.Value) Sheets("toutal").Select End If End Sub mango_MH.xlsm

اخي لم اكتشف اي خطا بالمعادلة قد تم اعادة تجربها مرة اخرى على ما يبدو لي انها صحيحة .وقمت بمقارنتها مع الملف المرفوع من استادنا الكبير محي الدين ابو البشر . تم الحصول على نفس النتيجة .شهر 8 =SOMME.SI.ENS(E10:E100;F10:F100;">="&D5;F10:F100;"<="&FIN.MOIS(D5;0))+SOMME.SI.ENS(G10:G100;H10:H100;">="&D5;H10:H100;"<="&FIN.MOIS(D5;0))+SOMME.SI.ENS(I10:I100;J10:J100;">="&D5;J10:J100;"<="&FIN.MOIS(D5;0))

جرب اخي هل هو المطلوب فعلا لاني حتى الانتهاء من وضع المعادلات اكتشفت وجود كود لاضافة اوراق جديدة تلقائيا وبهده الطريقة المعادلات الموضوعة لا يمكنها التعرف على الشيت المضاف الا بعد التعديل mango2021-2022-2023 (1).xlsm

وعليكم السلام ورحمة الله وبركاته هل نسخ القيم يقتصر على الأوراق الموجودة أم هناك احتمال الزيادة (hakan11 او 12)

العفو أخي الكريم

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

Sub MH_hyperkunks() Dim Ws As Worksheet Worksheets("toutal").Range("A3:a100").ClearContents Range("A3").Select For Each Ws In ActiveWorkbook.Worksheets If Ws.Name <> "toutal" Then ActiveCell.Hyperlinks.Add Anchor:=ActiveCell, Address:="", SubAddress:="" & Ws.Name & "!A1" & "", ScreenTip:="", TextToDisplay:=Ws.Name ActiveCell.Offset(1, 0).Select End If Next Ws End Sub mango2023(1).xlsm

تفضل اخي مثال توضيحي.xlsx

Sub change_selection() Dim MH_Range, New_Range As Range Set MH_Range = Selection Set New_Range = MH_Range.Resize(, 1).Offset(0, MH_Range.Columns.Count) New_Range.Select End Sub تحديد صف موازى لنطاق.xlsm

wor1.xlsm

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

Sub copy_columns_MH() Dim MH As Long, k As Long Dim lr As Integer, erow As Integer, sh1 As Worksheet, sh2 As Worksheet, i As Long Set sh1 = Worksheets("saad") Set sh2 = Worksheets("data") Application.ScreenUpdating = False Range("c10:L10000").ClearContents lr = sh1.Cells(Rows.Count, 3).End(xlUp).Row For i = 11 To lr erow = sh2.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Row sh2.Cells(erow, 4) = sh1.Cells(i, 2) sh2.Cells(erow, 5) = sh1.Cells(i, 4) sh2.Cells(erow, 6) = sh1.Cells(i, 5) sh2.Cells(erow, 7) = sh1.Cells(i, 7) sh2.Cells(erow, 8) = sh1.Cells(i, 9) sh2.Cells(erow, 9) = sh1.Cells(i, 10) sh2.Cells(erow, 10) = sh1.Cells(i, 11) sh2.Cells(erow, 11) = sh1.Cells(i, 12) sh2.Cells(erow, 12) = sh1.Cells(i, 15) Next i With Sheets("data") k = 1 For MH = 10 To .Range("D" & .Rows.Count).End(xlUp).Row If .Range("C" & MH) = valeu Then .Range("C" & MH) = k k = k + 1 End If Next MH End With Application.ScreenUpdating = True End Sub AHMAD - MH-3.xlsm

الملف الذي تم إرفاقه في المشاركة فوق ليس به أي مشكلة في الترحيل ربما قد غيرت شيئ ما بدون قصد على العموم قد تم حل المشكلة أما بالنسبة للتسطير كان عليك أولا تجرب تسطير ورقة saad وتشوف!!! تم إرفاق ملفان واحد بتسطير ورقة saad والثاني باستخدام التنسيق الشرطي .لكي تكتشف الفرق AHMED.rar

اقتراح ..يمكنك بعد وضعهم في ملف واحد اضافة ورقة جديدة تمكنك من استخراج المتغير بما ان رقم الهوية الوطنية هو عنصر ثابت لا يتغير يمكنك البحث به رغم اختلاف ترتيب الاسماء بمصنف1 و2 وطريقة البحث هي الاسم والهوية الوطنية من مصنف 1 لاعتبارة الشيت الرئيسي الدي يتضمن جميع الاسماء مع جلب باقي البيانات من مصنف 2 بشرط وجود نفس الاسم وعند كتابة الرقم الوظيفي فقط يتم جلب بيانات الاعمدة الاخرى تلقائيا..جرب اخي test.xlsx

السؤال لماذا لم يتم نسخ البيانات الجديدة فوق القديمة او جلبها دفعة واحدة دون تحديث كل اسم على حدى ؟ او ترحيل الأعمدة الأربعة فقط للمصنف الجديد!!!! لانه ليس هناك تغيير لا في مكان الأعمدة ولا في تنسيق الجدول . هل هناك اعمدة أخرى يجب تحديث بياناتها ؟

AHMAD - MH-2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تم انشاء كود جديد يلبي المطلوب بادن الله Sub M_H() Dim i As Long Dim MH As Long, k As Long Application.ScreenUpdating = False With Sheets("saad") lr = Cells(Rows.Count, 1).End(3).Row 'افراغ النطاق من البيانات السابقة قبل الترحيل Sheets("data").Range("c10:l" & lr).ClearContents lrow = .Cells(Rows.Count, 2).End(xlUp).Row ' الاعمدة المطلوب ترحيلها frt = Split("B,D,E,G,I,L,J,K,O", ",") 'الاعمدة المرحل اليها tot = Split("D,E,F,G,H,K,I,J,L", ",") For i = LBound(frt) To UBound(frt) 'نسخ البيانات ابتداءا من الصف العاشر .Range(frt(i) & "10:" & frt(i) & lrow).Copy Sheets("Data").Range(tot(i) & "10") Next i End With ' ترقيم تلقائي للصفوف المرحلة بشرط وجود قيمة في 'العمود(D) 'ابتداءا من الصف العاشر With Sheets("data") k = 1 For MH = 10 To .Range("D" & .Rows.Count).End(xlUp).Row If .Range("C" & MH) = valeu Then .Range("C" & MH) = k k = k + 1 End If Next MH End With ' كود اظافي 'With Sheets("data") '.Range("C10") = 1 '.Range("C11") = 2 '.Range("C10:C11").AutoFill .Range("C10:C" & lrow) 'End With End Sub AHMAD-MH.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي بعد تحميل الملف المضغوط سوف تجد مجلد باسم DATA C قم بنسخه الى القرص ثم افتح ملف سجل القيد وقم باستدعاء البيانات عادي الكود المستخدم Sub MH_data() Application.ScreenUpdating = False Set currentworkbook = ThisWorkbook Set sourceworkbook = Workbooks.Open("C:\DATA\Sheet1.xlsx") sourceworkbook.Worksheets("Sheet1").Range("a2:d500").Copy currentworkbook.Activate currentworkbook.Worksheets("Sheet1").Activate lastcell = Cells(Rows.Count, 2).End(xlUp).Row + 1 currentworkbook.Worksheets("Sheet1").Cells(lastcell, 2).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False sourceworkbook.Close Set sourceworkbook = Nothing Set currentworkbook = Nothing ThisWorkbook.Activate Worksheets("Sheet1").Activate Worksheets("Sheet1").Range("A4").Select Application.ScreenUpdating = True End Sub ملاحظة: يمكنك تغيير مسار الملف من هنا في حالة عدم توفر جهازك على قرص باسم C Set sourceworkbook = Workbooks.Open("C:\DATA\Sheet1.xlsx") سجل القيد_MH.rar

تفضل اخي Sub Hide_Rows_Zero_MH() Dim x1 As Long Dim x2 As Long Dim MH As Boolean For x1 = 4 To 15 MH = True For x2 = 2 To 5 If Cells(x1, x2).Value > 0 Then MH = False Exit For End If Next x2 Rows(x1).Hidden = MH Next x1 End Sub وهدا لاظهارها Sub shw_row() lr = Cells(Rows.Count, 1).End(4).Row Range("a4:a" & lr).EntireRow.Hidden = False End Sub اخفاء الصفوف الفارغة.xlsm

جرب مشروع.xlsx اخي

T3 جرب وضع هذه المعادلة في الخلية =SIERREUR(NB.SI.ENS(C$5:C$50;">="&$R3;D$5:D$50;"<="&$S3);"") تم وضع المعادلات في الملف المرفق Book1 M-H.xlsx

بالعكس انا بستخدم اوفيس 2016

يمكنك استخدام المعادلة التالية لاستخراج الفرق بالشهور =DATEDIF(H2;P2;"m") مثال 12/4/2022____27/4/2029________النتيجة هي 96 شهر وهده ادا كانت لك رغبة باستخراج النتيجة بالاعداد الكسرية =FRACTION.ANNEE(H2;P2)*12 12/4/2022____27/4/2029________ النتيجة هي 96.5 شهر ونصف Copy of Book13(2).xlsx

بعد تسمية النطاقات بخاصية (Name Manager) تم وضع معادلة البحث التالية =INDEX(Data!$C$3:$D$300;EQUIV('شهادة صف ثالث'!$K$47;Data!$C$3:$C$300;0);2) اما بالنسبة للصورة لم يتم وضع اي اطار خاص بها يمكنك تغيير مكانها كيفما شئت

1) لاحظت ان عدد الطلبة يفوق 200 طالب يستحيل انك تضيف كل صورة لوحدها 🤔🤔 اليك اخي الفاضل هدا الكود الدي سيمكنك من اضافة الصور دفعة واحدة ومرتبة (قبل تشغيل الكود تاكد من وقوفك على الخلية المراد اضافة الصورة اليها) 2) وهدا رابط شرح طريقة اضافة الصور للملف : https://streamable.com/ti3tnn Sub InsertMultiplePictures_MH() Dim Pictures() As Variant Dim PictureFormat As String Dim Rng As Range Dim PicShape As Shape On Error Resume Next Pictures = Application.GetOpenFilename(PictureFormat, MultiSelect:=True) xColIndex = Application.ActiveCell.Column If IsArray(Pictures) Then xRowIndex = Application.ActiveCell.Row For lLoop = LBound(Pictures) To UBound(Pictures) Set Rng = Cells(xRowIndex, xColIndex) Set PicShape = ActiveSheet.Shapes.AddPicture(Pictures(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height) xRowIndex = xRowIndex + 1 Next End If End Sub ولازالة الصور القديمة Sub DeleteImage() Dim pic As Picture For Each pic In ActiveSheet.Pictures If Not Application.Intersect(pic.TopLeftCell, Range("D3:D300")) Is Nothing Then pic.Delete End If Next pic End Sub تم اضافة الاكواد للملف المرفق شهادات صف ثالث_M-H.rar