سليم حاصبيا

اذا لم تعمل معك استبدل الفاصلة بفاصلة منقوطة(حسب اعدادات الجهاز عندك) لتبدو هكذا =SUBSTITUTE(TRIM(A1);CHAR(160);"")

جرب هذين الماكروين الماكرو الاول للقائم المنسدلة(مطاطة لا تذكر المكرر الا مرة واحدة و تتغيير مع تعديل البيانات) الماكرو الثاني على الزر "هات ماعندك" يقوم باستخراج المطلوب Option Explicit '+++++++++++++++++++++++++++++++++++++++++ Sub Salim_Data_Val() Dim D1 As Worksheet, D2 As Worksheet Set D1 = Sheets("Sheet1"): Set D2 = Sheets("Sheet2") Dim i#: i = 2 Dim arr Dim Laste_row# Laste_row = D1.Cells(Rows.Count, "A").End(3).Row Dim rg As Object Set rg = CreateObject("system.collections.arraylist") With rg Do Until i > Laste_row If Not .Contains(D1.Range("A" & i).Value) _ And D1.Range("A" & i) <> vbNullString Then _ .Add D1.Range("A" & i).Value i = i + 1 Loop .Sort arr = Join(.Toarray, ",") End With With D2.Range("F7") With .Validation .Delete .Add xlValidateList, Formula1:=arr End With End With Set rg = Nothing: Set D1 = Nothing: Set D2 = Nothing End Sub '++++++++++++++++++++++++++++++++++++++++++++++++++++++ Sub FilterME() Dim D1 As Worksheet, D2 As Worksheet Set D1 = Sheets("Sheet1"): Set D2 = Sheets("Sheet2") Dim f_Rg As Range Dim r, col D2.Range("G8", Range("M7").End(4)).ClearContents Set f_Rg = D1.Range("a1").CurrentRegion If D1.FilterMode Then D1.ShowAllData: f_Rg.AutoFilter End If r = f_Rg.Rows.Count col = f_Rg.Columns.Count f_Rg.AutoFilter 1, D2.Range("f7") f_Rg.Offset(1).Resize(r - 1).SpecialCells(12).Copy _ D2.Range("G8") f_Rg.AutoFilter End Sub الملف مرفق My_saerch.xlsm

جرب هذا المعادلة في B1 تم اسحب نزولاً =SUBSTITUTE(TRIM(A1),CHAR(160),"")

هذه المعادلة =SUMPRODUCT(B6:P6,B4:P4)

لعل هذا ما تريده الصفحة Salim من هذا الملف Example_Salim_Updated.xlsx

اذا كان هذا ما تريد توضيحه اضغط "افضل اجابة" لاغلاق الموضوع

لما تكتب 1/8/2017 اكسل يعطيك نتيجة قسمة 1 على 8 وما يتنج يقسمه على 2017 فيقرأ النتيجة 0.00006197 للمقارنة الصحيحة يجب هذه المعادلة =DATEVALUE("16/8/2017")<DATEVALUE("10/10/2017")

ربما كان المطلوب الحرف " م" لا يحتسب ضمن احصاء النجاح Example_Salim_NEW.xlsx

أسف ليس لدي الخبرة الكافية للبحث في النت من خلال الـــ Vba فهذا ليس من اختصاصي يمكنك الاستعانة بخاصية البحث في Google لايجاد هكذا اكواد

تم معالجة الامر Example_Salim.xlsx

وانتم بخير صديقي وجيه اعاده الله عليكم وعلى الامة العربية بالخير واليمن والبركات

تمت الاجابة على هذا العنوان https://www.officena.net/ib/topic/92726-معادلة-ايجاد-كل-القيم-التي-تخص-رقم-معين/?tab=comments#comment-583693

تعديل بسيط على هذا السطر في الكود Range("E" & i).Resize(, UBound(My_Arr)) = My_Arr ليصبح هكذا (زيادة واحد فقط) Range("E" & i).Resize(, UBound(My_Arr) + 1) = My_Arr

جرب هذا الملف يمكنك نقل المعادلة الى الملف عندك ARABIC_TIME.xlsx

استبدل الفاصلة المنقوطة " ;" بفاصلة عادية ", " (اينما تجدها داخل المعادلة) ربما تعمل معك المعادلة 1- حدد المعادلة من formula bar 2- اضغط Ctrl+H يظهر لك مربع بحث واستبدال 3 في مربع البحث اكتب الفاصلة المنقوطة 4-في مربع الاستبدال اكتب الفاصلة العادية 5- اضغط replace all

لاخذ العلم فقط كل عامود من اكسل 16 يحتوي على 1,048,576 صف وليس 148,000 فقط (اي 7 مرات اكثر مما تتوقع يا صديقي وسام) واذا اكتمل العامود يمكنك الانتقال الى عامود اخر من نفس الصفحة الذي يحتوي على نفس العدد من الصفوف (هناك 16,384 عامود) اي ما مجموعه 1,048,576 × 16,384= حوالي 17 مليار و 180 مليون خلية (سكان الارض ثلاث مرات) هذا الكلام في كل صفحة(Worksheet) من نفس المصنف (Workbook) فما بالك اذا كان المصنف يحتوي على 100 بل 1000 صفحة للتأكيد هذا الماكرو Sub test() Range("b1") = Range("a:a").Rows.Count & " Rows in each column" Range("b1").WrapText = False Range("b2") = Rows(1).Rows.Columns.Count & " columns in each row" Range("b2").WrapText = False End Sub

مباشرة قبل كلمة End sub في الماكرو الثاني (trasnfer_data) اضف هذا السطر Union(DE.Range("B3:B8"), DE.Range("D3:D8")).ClearContents

تم التعديل على اماكرو كما تريد Option Explicit Sub del_last_4() Dim cel As Range For Each cel In Range("F5", Range("M4").End(4)) If IsNumeric(cel) And _ cel <= 4 And _ Range("N" & cel.Row) = "مكمل" Then cel = vbNullString Next End Sub

جرب هذا الماكرو Option Explicit Sub del_last_4() Dim cel As Range For Each cel In Range("F5", Range("M4").End(4)) If IsNumeric(cel) And _ cel <= 4 Then cel = vbNullString Next End Sub

ما هو انت اذا حذفت الدرجة تتغيير النتيجة لتصبح ناجحاً لان المعادلة تطلب تنفيذ هذا الشيء

يظهر ان الاسماء تنقص الكثير لذلك اقترح هذا الكود (يقوم ايضاً بترتيب الاسماء ابجداً اذ اردت ذلك) واذا اردت ان تكون الترتيب حسب الورود في الجدول احذف السطر Sort . Option Explicit Sub Give_data() Dim i%: i = 2 Dim col As Object Range("H5", Range("H4").End(4)).ClearContents Set col = CreateObject("System.Collections.Arraylist") With col Do Until Range("b" & i) = vbNullString If Not (Range("b" & i) Like "*#*") And _ Not .Contains(Range("b" & i).Value) Then _ .Add Range("b" & i).Value i = i + 1 Loop .Sort Range("H5").Resize(.Count - 1) = Application.Transpose(.Toarray) Range("I5") = .Count - 1 .Clear End With Set col = Nothing End Sub الملف مرفق Book101_salim.xlsm

دائماً وأبداً يجب ارفاق ملف للعمل عليه حيث انك لم تفعل هذا اليك هذا النموذج عما تريد الكود Option Explicit Private Sub Workbook_SheetActivate(ByVal Sh As Object) Dim arr, x 'اكتب في هذه المصفوفة اسماء الشيات التي يمنع حذفها arr = Array("Sheet2", "Sheet4", "Sheet6") x = IsError(Application.Match(ActiveSheet.Name, arr, 0)) If Not x Then ThisWorkbook.Protect Else ThisWorkbook.Unprotect End If End Sub الملف مرفق PREVENT_DEL_SHEETS.xlsm

الملف عندك كبير جداَ حوالي 14 ميغا مع انه فارغ لماذا يا ترى امسح الملف نهائياً وقم بتصميم ملف بديل عنه بدون تنسيقات ملونة ( اللون الاصفر على كامل الصفحة لا ضرورة له) ثم جرب هذا الماكرو Option Explicit Sub ADD_SHE() Dim I%, T%: T = 2 For I = 1 To 14 Sheets(1).Copy AFTER:=Sheets(Sheets.Count) ActiveSheet.Name = T T = T + 1 Next End Sub

محاولة اخرى New_function.xlsx

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