محمد هشام.

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

تفضل اخي الفاضل Book2-M-H.xlsm

تفاديا للعمل على التخمين حاول رفع نسخة للملف

Rng_1.Copy sh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

Option Explicit Private Sub Workbook_Open() Application.Visible = False UserForm1.Show End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.Visible = True End Sub

جرب اخي المعادله التالية =IF(OR(I5="",H5="",J5=""), "",IF(J5-(I5+H5)<=25, "Pending", IF(AND(J5-(H5+I5)>=26,J5-(H5+I5)<=29),"Notify", IF(J5-(H5+I5)>=30,"Done", "")))) Test-M-H-4.xlsx

Test-M-H-3.xlsxجرب ممكن هذا ما تقصد