سليم حاصبيا

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

اولاً من باب الحفاظ على الملكية الفكرية يجب عليك ذكر من وضع لك المعادلات (UDF Function) ثانياً انت قمت بوضع ماكروات تمنع الحسابات (Xl Calculation=xlManual) لذلك لا يقوم الماكرو بتنفيذ المعادلات تم توقيف هذه الماكروات ثالثا ما ضرورة رفع ملف من اكثر من 1500 صف في حين 20 صف تكفي للمعاينة رابعاً تم معالجة الامر الملف مرفق work Sheet_salim.xlsm

جرب هذا الملف Ages.xlsx

ممكن ذلك من خلال هذا التعديل على الكود Option Explicit Sub Find_Dupl_Rows_new() Dim I%, Ro, m% Dim REP As Range, My_Rg As Range Dim COl As Collection Dim Arr, n Set COl = New Collection Set My_Rg = Range("A1").CurrentRegion Ro = My_Rg.Rows.Count Set My_Rg = My_Rg.Offset(1).Resize(Ro - 1) My_Rg.Interior.ColorIndex = xlNone Range("E2").Resize(Ro - 1).ClearContents Range("G2:K2").Resize(Ro - 1).Clear For I = 2 To Ro Arr = Application.Transpose(Application.Transpose _ ((Cells(I, 2).Resize(, 3)))) Arr = Join(Arr, "*") On Error Resume Next COl.Add I, Arr If Err.Number <> 0 Then m = m + 1 Cells(I, 5) = "Duplicate" Cells(I, 5).Interior.ColorIndex = 40 If REP Is Nothing Then Set REP = Cells(I, 2).Resize(, 3) Else Set REP = Union(REP, Cells(I, 2).Resize(, 3)) End If 'REP End If 'Err Next I On Error GoTo 0 If Not REP Is Nothing Then REP.Interior.ColorIndex = 40 MsgBox "You have :" & m & " duplicate Rows" n = REP.Areas.Count m = 1 For I = 1 To n Range("G1").Offset(m).Resize(REP.Areas(I). _ Rows.Count, 3).Value = REP.Areas(I).Value Range("j1").Offset(m) = REP.Areas(I).Address Range("K1").Offset(m) = REP.Areas(I).Rows.Count m = m + REP.Areas(I).Rows.Count Next '================================= With Cells(2, "g").Resize(m - 1, 5) .Borders.LineStyle = 1: .Font.Size = 16 .Font.Bold = True: .Interior.ColorIndex = 28 .InsertIndent 1 End With '========================= Else MsgBox "Not duplicate Rows " End If Set COl = Nothing: Set REP = Nothing End Sub

See this file E2.xlsx

تم التعديل قليلاً على الموضوع السابق لادراج الصفوف المكررة وليس فقط تحديدها Find_dup_rows_NEW.xlsm

جرب هذه المعادلة =EDATE($A$1,$A$2)

جرب هذا الملف Tekrar_new.xlsx

جرب هذا الملف My_Book.xlsm

وهذا ما يفعله الكود الذي رفعته لك بالضبط (لكن بدون رقم سري ) اذا اردت يمكن وضع رقم سري بالكود

تم التعديل Option Explicit Sub del_data() Dim Cel_1, Cel_2, x%, y% Cel_1 = Range("B4"): Cel_2 = Range("C4") x = Cel_1 Like "#*" y = Cel_2 Like "#*" If x * y <> 0 Then Cel_1 = "G" & Cel_1 Cel_2 = "G" & Cel_2 Range(Cel_1 & ":" & Cel_2).ClearContents End If End Sub

جرب هذا الملف (اذا كنت ما فهمته عليك صحيحاً) My_Macro.xlsm

لم أفهم سؤالك جيداَ يمكنك الذهاب الى اي خلية رقم عامودها اكبر من 3 هناك طريقة ثانية بحماية الصفحة مع عدم السماح بالتحرير في هذه الثلاثة أعمدة مثلاً Sub Protct_Three_columns() With Sheets("ورقة1") .Unprotect .ScrollArea = "" .Cells.Locked = False .Range("A3:c3").EntireColumn.Locked = True .Protect End With End Sub

في نفس الكود ضع مكان .Delete Shift:=xlUp العبارة التالية ClearContents

صدقني لم افهم شيئاً من الماكرو الذي عندك 50 مرة Select دون جدوى اشرح بالتفصيل الصفحة المصدر ؟؟ الصفحة الهدف؟؟؟؟ ما هو النطاق الذي سيرحل ؟؟؟

جرب هذا الكود Option Explicit Sub del_data() Dim Cel_1$, Cel_2$, x%, y% Cel_1 = Range("B4"): Cel_2 = Range("C4") x = Cel_1 Like "[A-Za-z]*#*" y = Cel_2 Like "[A-Za-z]*#*" If x * y <> 0 Then _ Range(Cel_1 & ":" & Cel_2).Delete Shift:=xlUp End Sub

لمعالجة الامر ارفع نسخة مختصرة عن الملف (2 أو 3 شيتات) مع شرح لما هو مطلوب

مهما كان نوع الصيغة فالرقم لم يعد رقمًا بل اصبح نصاً (جرب ان تجمعه مع اي رقم اخر) تحصل على خطأ

هذه المعادلة في الخلية C2 واسحب الى اخر خلية =A2&""

لا ارى اي معادلة في الملف وقم بتلوين الخلايا التي تريد تفريغها بلو ن مميز(غير فاقع)

انا وضعت لك المعادلة في النطاق من E8 الى E27 فقط تم تعديل الملف كما تريد Alpha_1.xlsx

المعادلة نعمل بكفاءة لا أعلم ما السبب عندك

انا بالحقيقة لا احب ان اتعامل مع اليوزر لذلك وجدت لك هذه الطريقة(عسى ان تنال الإعجاب) و هناك مجال اخر للعمل بواسطة الماكرو الكود Option Explicit Sub TEST() If ActiveSheet.Name <> "Salim" Then Exit Sub Dim I%, M%, X%, T% Dim arr, nEW_KEY, ky Dim Dic As Object, AL_DIC As Object Set Dic = CreateObject("Scripting.Dictionary") Set AL_DIC = CreateObject("Scripting.Dictionary") Range("H3").CurrentRegion.Clear I = 4 Do Until Cells(I, 1) = vbNullString If Not Dic.EXISTS(Cells(I, 1).Value) Then Dic.Add (Cells(I, 1).Value), Cells(I, 2).Value Else Dic(Cells(I, 1).Value) = Dic(Cells(I, 1).Value) & _ "*" & Cells(I, 2).Value End If I = I + 1 Loop For Each ky In Dic.KEYS arr = Split(Dic.Item(ky), "*") For M = LBound(arr) To UBound(arr) AL_DIC(arr(M)) = "" Next M Range("H3").Offset(, T) = ky For Each nEW_KEY In AL_DIC Range("H3").Offset(X + 1, T) = nEW_KEY X = X + 1 Next nEW_KEY AL_DIC.RemoveAll T = T + 1: X = 0 Next ky Set AL_DIC = Nothing: Set Dic = Nothing Erase arr With Range("H3").CurrentRegion .Borders.LineStyle = 1: .InsertIndent 1 .Font.Size = 14: .Font.Bold = True .Interior.ColorIndex = 40 End With End Sub الملف مرفق My_test2020.xlsm

لا أعلم اذا كان هذا المطلوب Education_Job.xlsx

معادلة ممتازة لكن: اكتب في اي خلية نص مثلاً A وليس رقم و ترى النتيجة