سليم حاصبيا

الماكرو الصحيح للمصنف الأول find.xls حاول تعديله لبتناسب مع المطلوب Sub NEW_MACRO() Range("C2").CurrentRegion.Offset(1).ClearContents Dim My_Adr$ i = 1 w = InputBox("Find", "Find What:", "") If w = vbNullString Then Exit Sub For Each sh In Worksheets If sh.Name = "Sheet" Then Exit Sub With sh.Range("C7:C500") Set a = .Find(w) If Not a Is Nothing Then My_Adr = a.Address f = My_Adr Do i = i + 1 x = a.Row y = a.Column With Sheets("sheet").Cells(i, 5) .Value = My_Adr .Offset(, -2) = Sheets(sh.Name).Cells(x, y - 2) .Offset(, -1) = Sheets(sh.Name).Cells(x, y - 1) .Offset(, 1) = Sheets(sh.Name).Cells(x, y + 3) End With Set a = .FindNext(a) My_Adr = a.Address If f = My_Adr Then Exit Do Loop End If End With Next sh End Sub

مزيد المزيد في هذا الملف مع الشرح الوافي UDF_tekrar 8yab .xlsm

تم معالجة الأمر tekrar 8yab _Month.xlsm

في الخلية I5 هذه المعادلة ( Ctrl+Shift+Enter) =SUM(--(ISNUMBER(FIND(I$3,$G$5:$G$16)))) tekrar 8yab.xlsm

هذا ملف اخر لا يأخذ بعين الاعتبار ما تحتويه الخلايا (فقط ينظر الى الارقام بين 1 و نهاية الشهر) ولا ينظر الى الفواصل اي كانت (فواصل نص * \ / الخ.....) Option Explicit Sub Saerch_date() Dim regex As Object, str As String Set regex = CreateObject("VBScript.RegExp") With regex .Global = True .IgnoreCase = True .Pattern = "([1-3]?\d+)" End With Dim MY_Match, x%, s$, i%, m%: m = 1 Dim Days_num$, Final_Month% Dim my_array() Dim arr_arab(1 To 7) arr_arab(1) = "الأحد": arr_arab(2) = "الإثنين" arr_arab(3) = "الثلاثاء": arr_arab(4) = "الأربعاء" arr_arab(5) = "الخميس": arr_arab(6) = "الجمعة" arr_arab(7) = "السّبت" Range("E5:E16,G5:G16").ClearContents For i = 5 To 16 Set MY_Match = regex.Execute(Range("c" & i)) If MY_Match.Count = 0 Then GoTo next_i For x = MY_Match.Count - 1 To 0 Step -1 Final_Month = Month(DateSerial([E2], i - 4, MY_Match(x))) If Final_Month = i - 4 Then Days_num = Weekday(DateSerial([E2], i - 4, MY_Match(x))) ReDim Preserve my_array(1 To m) my_array(m) = arr_arab(Days_num) m = m + 1 End If Next x Range("E" & i) = m - 1 s = Join(my_array, ",") Range("G" & i) = s s = "": m = 1: Erase my_array next_i: Next Set regex = Nothing Erase arr_arab End Sub الملف مرفق khairi ali_Extra.xlsm

احي مصطفى لا داعي للسطر الذي قلت عنه لانه في الكود مذكور أن يتجاوز الخلايا الفارغة ) المطلوب فقط ان تترك الخلية فارغة ولا يتم وضع لا " 0" ولا " -" ولا اي شيء آخر يتم ادراج فقط ارقام من 1 الى نهاية الشهر حسب الخلية المناسبة في العامود C يتوسط الرقمين "-" للتوضيح هذه الصورة

ربما يكون الحل Option Explicit Sub Get_days() Dim i%, k%, m%, it Dim arr(), cont Dim st$ Dim Days_num% Dim arr_arab(1 To 7) arr_arab(1) = "الأحد": arr_arab(2) = "الإثنين": arr_arab(3) = "الثلاثاء" arr_arab(4) = "الأربعاء": arr_arab(5) = "الخميس": arr_arab(6) = "الجمعة" arr_arab(7) = "السّبت" Dim dict As Object m = 1 Set dict = CreateObject("Scripting.Dictionary") For i = 5 To 16 If Range("c" & i) <> "" Then With dict cont = Split(Range("c" & i), "-") .Add i - 4, cont For Each it In .Items ReDim Preserve arr(1 To 1) arr(1) = it Range("e" & i) = UBound(cont) + 1 For k = UBound(cont) To 0 Step -1 Days_num = Weekday(DateSerial([E2], i - 4, cont(k))) st = st & arr_arab(Days_num) & "," Range("g" & i) = Left(st, Len(st) - 1) & "." Next Next .RemoveAll Erase arr st = vbNullString End With End If Next End Sub الملف مرفق khairi ali.xlsm

جرب هذا الملف حيث ان يوفر عليك وقت كتابة الاسم و امكانية الخطأ في الكتابة schools.xlsm

استبدل المعادلة الى هذه (Ctrl+Shift+Enter) بعد تغيير اسم الصفحة من شهر 1 الى Month1 =INDEX(Month1!$B$2:$B$218,MATCH((D2&"*"&C2),Month1!$E$2:$E$218&"*"&Month1!$D$2:$D$218,0)) الملف مرفق salim_formula.xlsm

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

ممكن هذا الماكرة ان يفي بالغرض Option Explicit Sub Find_Missing_number() Dim RG As Range Dim i#, C#, Col#, M# Dim My_Max#, My_Min# Dim T#: T = Sheets("Sheet1").Range("a1").CurrentRegion.Columns.Count Dim My_count# M = 1 Dim dic As Object Sheets("salim").Cells.Clear Set dic = CreateObject("scripting.dictionary") For C = 1 To T Set RG = Sheets("Sheet1").Range("a1").CurrentRegion.Columns(C) My_Max = Application.Max(RG) My_Min = Application.Min(RG) With dic For i = My_Min To My_Max If IsError(Application.Match(i, RG, 0)) Then If Not .exists(i) Then .Add i, "" End If End If Next My_count = .Count With Sheets("salim").Cells(1, M) If My_count <> 0 Then .Value = "Missing in col " & C .Interior.ColorIndex = 4 .Font.ColorIndex = 1 With .Offset(1).Resize(My_count) .Value = Application.Transpose(dic.keys) .Interior.ColorIndex = 6 End With Else .Value = " Not Missing in col " & C .Interior.ColorIndex = 5 .Font.ColorIndex = 2 End If End With M = M + 1 End With dic.RemoveAll Next With Sheets("salim") .Columns.AutoFit .Range("a1").CurrentRegion. _ SpecialCells(2, 23).Borders.LineStyle = 1 End With Set dic = Nothing: Set RG = Nothing End Sub الملف مرفق Small_book.xlsm

لقد قمت بتحميل ملف كبير جداً يصعب فيه مراقبة سير المعادلات لذا وضعت لك هذا النموذج يمكن فيما بعد تكبير النطاق الى اي رقم تريد واذا اردت يمكن ان تكون التنيجة في صفحة اخرى الكود Option Explicit Sub find_missing() Dim i, k%: k = 1 Dim Rg As Range: Set Rg = Range("a1").CurrentRegion Dim coll_1 As Object Dim coll_2 As Object Dim arr1, arr2, total_arr() Set coll_1 = CreateObject("system.collections.arraylist") Set coll_2 = CreateObject("system.collections.arraylist") Range("G2:H" & Rows.Count).ClearContents With coll_1 For i = 1 To Rg.Cells.Count If Not .contains(Rg.Cells(i).Value) Then .Add Rg.Cells(i).Value End If Next .Sort arr1 = .toarray .Clear End With '========================== With coll_2 For i = 1 To Rg.Cells.Count If Not .contains(i) Then .Add i End If Next .Sort arr2 = .toarray .Clear End With Range("G2").Resize(UBound(arr1) - LBound(arr1) + 1) = _ Application.Transpose(arr1) '==================== For i = 0 To Rg.Cells.Count - 1 If IsError(Application.Match(arr2(i), arr1, 0)) Then ReDim Preserve total_arr(1 To k) total_arr(k) = arr2(i) k = k + 1 End If Next Range("H2").Resize(k - 1) = _ Application.Transpose(total_arr) Erase arr1: Erase arr2 Set coll_1 = Nothing: Set coll_2 = Nothing End Sub الملف مرفق Find_Missing .xlsm

أظن أنه من الأفضل العمل من هلال الكود Option Explicit Sub sort_by_collections() Dim obj As Object Dim i% Dim ro%: ro = Cells(Rows.Count, 2).End(3).Row Range("D3:F100").ClearContents If ro < 3 Then ro = 3 Set obj = CreateObject("System.Collections.ArrayList") With obj For i = 3 To ro If Range("b" & i) <> "" _ And Not .contains(CDate(Range("b" & i))) _ And Range("b" & i) >= Range("g2") _ And Range("b" & i) <= Range("H2") Then .Add Range("b" & i).Value End If Next .Sort Range("d3").Resize(.Count - 1).Value = _ Application.Transpose(.toarray) .Reverse Range("f3").Resize(.Count - 1).Value = _ Application.Transpose(.toarray) End With Set obj = Nothing End Sub الملف مرفق Register_salim.xlsm

تم التعديل 1-بعد اختيار (العنوان الذي تريد ) من الكومبو الاول 2- اختر من الثاتي المعيار الذي تريد 3-اضغط الزر Multi_CHOISE.xlsm

المشكلة سهلة جداً (على فكرة أين الاعجاب) فقط اضافة سطر واحد على الكود(ما بين علامات +++++++) '+++++++++++++++++++++++++++++++++++++++++++++++ ARCHIVE.Range("b2").CurrentRegion.Sort key1:=ARCHIVE.Range("h2"), Header:=1 '++++++++++++++++++++++++++++++++++++++++++++++++ ليصبح الكود هكذا Option Explicit Sub hide_rows() Dim my_rg As Range Dim Copy_Rg As Range Dim find_Rg As Range Dim St$: St = "انتهى" Dim R%, Ro%, x% Application.ScreenUpdating = False ARCHIVE.Range("b2").CurrentRegion.Offset(1).Clear Set my_rg = Main.Range("b3").CurrentRegion.Columns(1) x = my_rg.Rows.Count Set find_Rg = my_rg.Find(St, after:=my_rg.Cells(x)) If Not find_Rg Is Nothing Then R% = find_Rg.Row: Ro = R Main.Range("b" & Ro).EntireRow.Hidden = True Do If Copy_Rg Is Nothing Then Set Copy_Rg = Main.Range("b" & Ro).Resize(, 10) Else Set Copy_Rg = Union(Copy_Rg, Main.Range("b" & Ro).Resize(, 10)) End If Set find_Rg = my_rg.FindNext(find_Rg) Ro% = find_Rg.Row Main.Range("b" & Ro).EntireRow.Hidden = True If Ro = R Then Exit Do Loop Copy_Rg.Copy ARCHIVE.Range("b2") ARCHIVE.Columns("b:k").AutoFit End If '+++++++++++++++++++++++++++++++++++++++++++++++ ARCHIVE.Range("b2").CurrentRegion.Sort _ key1:=ARCHIVE.Range("h2"), Header:=1 '++++++++++++++++++++++++++++++++++++++++++++++++ Application.ScreenUpdating = True End Sub '============================================ Sub show_all() Application.ScreenUpdating = False Main.Rows.Hidden = False Application.ScreenUpdating = True End Sub Sort_hide_special_rows.xlsm

جرب هذ الماكرو Option Explicit Sub hide_rows() Dim my_rg As Range Dim Copy_Rg As Range Dim find_Rg As Range Dim St$: St = "انتهى" Dim R%, Ro%, x% Application.ScreenUpdating = False ARCHIVE.Range("b2").CurrentRegion.Offset(1).Clear Set my_rg = Main.Range("b3").CurrentRegion.Columns(1) x = my_rg.Rows.Count Set find_Rg = my_rg.Find(St, after:=my_rg.Cells(x)) If Not find_Rg Is Nothing Then R% = find_Rg.Row: Ro = R Main.Range("b" & Ro).EntireRow.Hidden = True Do If Copy_Rg Is Nothing Then Set Copy_Rg = Main.Range("b" & Ro).Resize(, 10) Else Set Copy_Rg = Union(Copy_Rg, Main.Range("b" & Ro).Resize(, 10)) End If Set find_Rg = my_rg.FindNext(find_Rg) Ro% = find_Rg.Row Main.Range("b" & Ro).EntireRow.Hidden = True If Ro = R Then Exit Do Loop Copy_Rg.Copy ARCHIVE.Range("b2") ARCHIVE.Columns("b:k").AutoFit End If Application.ScreenUpdating = True End Sub '============================================ Sub show_all() Application.ScreenUpdating = False Main.Rows.Hidden = False Application.ScreenUpdating = True End Sub الملف مرفق hide_special_rows.xlsm

هذا ما استطعت أن أقوم به (في هذا الملف) saerch_Ameel_BY_CHOISE.xlsm

جرب هذا الملف تم استعمال الكومبو بدل التكست بوكس لاختيار ما تشاء من القائمة saech_Ameel.xlsm

بالنسبة للنقطتين يمكن حذفها من المعادلة نفسها و عند نسخ المعادلة الى مكانها لا تضغط على Enter وحدها بل على Control+shift+Enter بحيث تكبس باستمرار على المفتاحين Control+shift ثم تنقر Enter

تم التعديل Tartib_all_1.xlsm

من باب حفظ حقوق النشر والملكية الفكرية كان يجب ان تذكر واضع الدالة (المعرفة) التي قمت باستعمالها ()OrdeUP100 تحت طائلة عدم الرد على المشاركة مع امكانية جذفها يمكن أن يكون المطلوب في هذا الملف Tartib_all.xlsm

يمكن ان يكون الحل البيانات كثيرة جداً ومن الصعب رؤية نتيجة المعادلة (يمكن استعمال الفلتر لتحديد اي شخص و التأكد من البيانات) أرجو ان تكون صحيحة (في المرة المقبلة حاولي اختصار الملف الى 10- 15 صف ) لتحديد نتيجة المعادلة تم تعميمها على نطاق أوسع ترحيل 3 شروط .xlsx

كان يجب ان ترفع ملف للمعالجة لكن للمرة الاولى ارفق لك مثالاً عما تريد laste_neg.xlsx

قم بنسخها مكان الاولى هذا الملف للتوضيح Slash with Numbers.xlsx

جرب هذا الملف 55s.xlsx