سليم حاصبيا

جرب هذا الملف (معادلات مطاطة حتى 100 صف و يمكن الزيادة) مع حرية احتيار عدد الصفوف المطلوبة ( 10 أكثر اقل ) Ali_m.xlsx

Try his file Code_Number.xlsx

لو فرضنا ان هذه العلامة موجودة في العامود الأول A هذا الماكرو يقوم بما تريد Option Explicit Sub Test() Dim Ro#, i# Ro = Cells(Rows.Count, 1).End(3).Row For i = 1 To Ro If Range("A" & i) <> vbNullString Then Range("A" & i) = _ Replace(Range("A" & i), Chr(39), """") End If Next End Sub

شاهد هذا الفيديو https://www.youtube.com/watch?v=15q8PMe-oPo&ab_channel=DineshKumarTakyar

بعد عماية الفلترة اضغط الزر Run Option Explicit Sub DATA_VAL() Dim MY_RG As Range Dim ro%, cel As Range Dim dic As Object Set dic = CreateObject("Scripting.Dictionary") Set MY_RG = Range("E4").CurrentRegion.Columns(1) If MY_RG.Rows.Count = 1 Then Exit Sub Set MY_RG = MY_RG.Offset(1).Resize(MY_RG.Rows.Count - 1) For Each cel In MY_RG.Cells If cel.EntireRow.Hidden = False Then dic(cel.Value) = "" End If Next With Range("I3").Validation .Delete .Add 3, Formula1:=Join(dic.keys, ",") End With Set MY_RG = Nothing: Set dic = Nothing End Sub الملف مرفق bashiri.xlsm

ربما يكون المطلوب ABOU_TIBA.xlsm

3 ساعات من العمل المتواصل لايجاد الماكرو المناسب ثم تقول لي :ممكن تصحيح المعادلة بلاش الماكرو اذ امكن؟؟؟؟؟؟ أرفض هذا العرض

الماكرو لهذه الغاية للزر Save كما في الصورة (يجب التعميم على كافة الأزراربهذا الشكل) الملف مرفق My_List.xlsm

تم معالجة الأمر 1- تم اخفاء بعض الأعمدة لرؤية عمل الماكرو النتيجة في النطاق $AP$2:$AQ$15 Ali.xlsm

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

و ما الداعي للاعتذار دع السائل يعرف كل الاساليب التي تؤدي الى المطلوب

انظر الى الصورة

في الملف هناك اقتباس لبعض المعادلات من مشاركات سابقة بهذا المنتدى ولم تذكر صاحب المعادلات مما اجده مخالفاً لأنظمة المنتدى وتعدياً على الملكية الفكرية 1- الملف عندك متشابك بشكل لا يمكن فهمه بسهوله هذا بالاضافة الى كثرة الالوان والتنسيقات التي تجعل ممن يريد المساعدة ينفر مما يراه 2- تم وضع هذا الملف (نموذج لما تريد) يمكنك نسخ الماكرو و التعدبل عليه كما تراه مناسباً Max_by_sum.xlsm

تم التعديل 1- اختر اسم الشيت المطلوبة من القائمة المنسدلة (F2 ) 2 -القائمة المنسدلة تتحدّث كلما أضفت شيت جديد او حذفت شيت Abou_Yousef_1.xlsm

حسب طلبك مع وجود شيتات كثيرة

شاهد هذا الفيديو https://www.youtube.com/watch?v=FzxsNLq3VCA&ab_channel=pcshastra

جرب هذا الكود Option Explicit Sub All_uniques() Dim sh As Worksheet Dim F As Worksheet Dim Dic As Object Dim i%, Ro Set F = Sheets("Final") Set Dic = CreateObject("Scripting.Dictionary") For Each sh In Sheets If sh.Name <> F.Name Then Ro = sh.Cells(Rows.Count, 3).End(3).Row For i = 2 To Ro If IsNumeric(sh.Cells(i, 3)) Then Dic(sh.Cells(i, 3).Value) = vbNullString End If Next i End If Next sh F.Range("B:B").ClearContents If Dic.Count Then F.Cells(1, "B") = "All Uniques" F.Cells(2, "B").Resize(Dic.Count) = _ Application.Transpose(Dic.keys) End If Set sh = Nothing: Set F = Nothing Set Dic = Nothing End Sub الملف مرفق ( الصفحة Final ) Abou_Yousef.xlsm

ما هذا التناقض في المعطيات: من جهة الخليتين F2 و G2 بالأصل سوف يكون محتواهما إما 1 او فارغة من جهة احرى الخليتين F2 و G2 يوجد بها معادلات ودوال 1- اثناء العمل على ملفك تفحصت الحلايا و لم اجد اي معادلة في كل الصفحة 2 - ما الفائدة من مسح الخلايا تم استعادتها ؟؟؟

تم التعديل على الماكرو كما تريد Option Explicit Sub from_sheet_to_other() Dim D As Worksheet Dim t As Worksheet Dim F_rg As Range Dim Cret$, Rot%, Rod%, m% Application.ScreenUpdating = False Set D = Sheets("Data") Set t = Sheets("target") If D.AutoFilterMode Then _ D.Range("A5").AutoFilter Rot = t.Cells(Rows.Count, 1).End(3).Row Rot = IIf(Rot < 6, 6, Rot + 1) Rod = D.Cells(Rows.Count, 1).End(3).Row Set F_rg = D.Range("A5:F" & Rod) Cret = "محول من المدرسة" F_rg.AutoFilter 6, Cret On Error Resume Next D.Range("A6:F" & Rod).SpecialCells(12).Copy _ t.Range("A" & Rot) D.Range("A6:F" & Rod).SpecialCells(12).EntireRow.Delete On Error GoTo 0 If D.AutoFilterMode Then _ D.Range("A5").AutoFilter Application.ScreenUpdating = True End Sub Aysam_1.xlsm

جرب هذا الكود Option Explicit Sub from_sheet_to_other() Dim D As Worksheet Dim T As Worksheet Dim F_rg As Range Dim Cret$ Application.ScreenUpdating = False Set D = Sheets("Data") Set T = Sheets("target") T.Range("A5").CurrentRegion.Clear Set F_rg = D.Range("A5").CurrentRegion Cret = "محول من المدرسة" F_rg.AutoFilter 6, Cret F_rg.SpecialCells(12).Copy _ T.Range("A5") If D.AutoFilterMode Then _ D.Range("A5").AutoFilter Application.ScreenUpdating = True End Sub الملف مرفق Aysam.xlsm

Try this macro Option Explicit Sub One_Or_Nothing() Const t = 1 Dim i% Range("H2:H46").ClearContents For i = 2 To 49 If Application.CountIf(Range("F" & i).Resize(, 2), t) = 2 Then Range("F" & i).Resize(, 2).ClearContents Range("F" & i).Offset(, 2) = t End If Next End Sub

و اذا كانت لا تساوي 1 وليست فارغة مثلاً "Ok2" & "Ok1" ما العمل ؟؟؟؟

يمكن عمل هذا لكن بيوزر ثاني غير الذي رفعته انت (مع الغلم اني لا أجب ان أعمل على اليورز فورم) 1- لإعادة ترتيب الأعمدة اضغط الزر Reset 2- لمسح TextBoxes والــــ Labels اضغط الزر Cancel 3-لاختيار اي ترتيب للأعمدة املأ الـــ TextBoxes بما تريد ( لا تقبل الا احرف من B الى G ) والــــ Labels تتحدّث اوتوماتيكياً عند الخروج من الـــ TextBoxe بواسطة Enter او Tab أو Arrow 4 - لترحيل البيانات حسب الترتيب الذي اخترته (ليس من الضروروة اختيار كل الاعمدة) اضغط الزر ترحيل يتم نقل فقط الأعمدة المختارة جرب هذا الملف (مع الدعاء لانتصار الثّورة اللّبنانيّة) Fathi_Extra.xlsm

بعد تنفيذ المعادلة يجب ان تضغط هنا

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