سليم حاصبيا

تم عمل ذلك يعون الله مطعم Salim.xlsm

هذه المعادلة تستعملها مع(Ctl+Shift+Enter) وليس ( Enter)وحده =MAX((IF($B$4:$B$7=$E$16,INDEX($C$4:$H$7,MATCH($E$16,$B$4:$B$7,0),))*($C$3:$H$3="شراء")))

قليل من التحسين على الكود (ازالة حلقة تكرارية- للتلوين ) و تحديد نهاية الحلقة التكرارية الأولى حتى نهاية الشهر و ذلك يجعله اسرع Option Explicit Option Base 1 Sub My_Calandar1() If ActiveSheet.Name <> "Salim_Calendar" Then Exit Sub Dim t As Date, Search_Day As Date Dim Arab_day(), EnG_day() Dim i As Byte, m As Byte, r As Byte, _ My_Max As Byte, rows_count As Byte rows_count = Range("b4").CurrentRegion.Rows.Count + 3 Range("b4:H" & rows_count).ClearContents Range("b5:h10").Interior.ColorIndex = 0 '''''''''''''''''''''''''Conditions for working'''''''''''''''''' If Not IsNumeric([b1]) Or Not IsNumeric([b2]) _ Or [b1] < 1 Or [b2] > 12 Or [b2] < 1 Then MsgBox "Type Valid Numbers in cell(B1) & cell(B2)": Exit Sub End If ''''''''''''''''''''''''' End of Conditions for working'''''''''''''''''' r = 5 t = DateSerial([b1], [b2], 1) My_Max = Day(Application.EoMonth(t, 0)) '''''''''''''''''''''''''Conditions for Special Day'''''''''''''''''' If Not IsNumeric([g1]) Or [g1] > Day(Application.EoMonth(t, 0)) _ Or [g1] < 1 Then [g1] = 1 Else [g1] = Int([g1]) End If '''''''''''''''''''''''''End of Conditions Special Day'''''''''''''''''' Search_Day = DateSerial([b1], [b2], [g1]) Arab_day = Array("الأحد", "الإثنين", "الثلاثاء", _ "الأربعاء", "الخميس", "الجمعة", "السّبت") ' EnG_day = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat") Range("b4").Resize(, 7) = Arab_day m = Weekday(t) + 1 For i = 1 To My_Max With Cells(r, m) .Value = t .Interior.ColorIndex = 35 t = t + 1 m = m + 1 If .Column > 7 Then r = r + 1: m = 2 End With Next Range(Range("b5:h9").Find(Search_Day).Address).Interior.ColorIndex = 3 Erase Arab_day End Sub

يمكن ان يكون الحل (في حال اضافة احياء جديدة يتم انشاء صفحات جديدة لها) الكود Option Explicit Sub CreateSheets_WITH_FILTER() Application.ScreenUpdating = False Dim ws As Worksheet Dim FILTER_RG As Range Dim ListSh As Range Dim i%, last_row As Long Dim Y$, SALIM As Range Dim Sw_sh As Worksheet Set Sw_sh = Sheets("مبيعات") With Sw_sh last_row = .Cells(.Rows.Count, "E").End(xlUp).Row Set ListSh = .Range("E2:E" & last_row) Set FILTER_RG = .Range("B1:F" & last_row) End With On Error Resume Next For Each SALIM In ListSh If Len(Trim(SALIM.Value)) > 0 Then Y = Worksheets(Trim(SALIM.Value)).Name If Y = vbNullString Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = SALIM.Value End If Y = Empty End If Next SALIM Sw_sh.Select For i = 2 To Sheets.Count With Sheets(i) .Cells.Clear .Range("a1") = "حساب " & .Name .Columns("B:F").ColumnWidth = 12.85 End With Next For i = 2 To Sheets.Count If FILTER_RG.AutoFilter = False Then FILTER_RG.AutoFilter FILTER_RG.AutoFilter FIELD:=4, Criteria1:=Sheets(i).Name FILTER_RG.SpecialCells(2, 23).Copy Sheets(i).Range("B2") FILTER_RG.AutoFilter Next Application.ScreenUpdating = True End Sub الملف ترحيل salim.xlsm

طلب الي احد الاصدقاء وضع كود لادراج رزنامة لسنة محددة وشهر محدد مع تمييز (يوم معيّن) من هذا الشهر فكان هذا الكود الذي ارجو ان يستفيد منه الاخرون قبل تنفيذ الكود الكود: تسمية الصفحة التي تريد العمل عليها بهذا الاسم "Salim_Calendar" اكتب في الخلية B1 رقم السنة في الخلية B2 رقم الشهر في الخلية G1 رقم اليوم المييز الكود Option Explicit Option Base 1 Sub My_Calandar() If ActiveSheet.Name <> "Salim_Calendar" Then Exit Sub Dim t As Date, i As Byte Dim Arab_day(), m% Dim EnG_day(), rows_count As Byte Dim col As Byte Dim r As Byte Dim search_day As Date rows_count = Range("b4").CurrentRegion.Rows.Count + 3 Range("b4:H" & rows_count).ClearContents Range("b5:h10").Interior.ColorIndex = 0 '''''''''''''''''''''''''Conditions for working'''''''''''''''''' If Not IsNumeric([b1]) Or Not IsNumeric([b2]) _ Or [b1] < 1 Or [b2] > 12 Or [b2] < 1 Then MsgBox "Type Valid Numbers in cell(B1) & cell(B2)": Exit Sub End If ''''''''''''''''''''''''' End of Conditions for working'''''''''''''''''' r = 5 t = DateSerial([b1], [b2], 1) '''''''''''''''''''''''''Conditions for Special Day'''''''''''''''''' If Not IsNumeric([g1]) Or [g1] > Day(Application.EoMonth(t, 0)) _ Or [g1] < 1 Then [g1] = 1 Else [g1] = Int([g1]) End If '''''''''''''''''''''''''End of Conditions Special Day'''''''''''''''''' search_day = DateSerial([b1], [b2], [g1]) Arab_day = Array("الأحد", "الإثنين", "الثلاثاء", _ "الأربعاء", "الخميس", "الجمعة", "السّبت") ' EnG_day = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat") Range("b4").Resize(, 7) = Arab_day m = Weekday(t) + 1 For i = 1 To 31 Cells(r, m) = t If t = search_day Then Cells(r, m).Interior.ColorIndex = 3 Else Cells(r, m).Interior.ColorIndex = 35 End If If Month(t + 1) > [b2] Then Exit For t = t + 1 m = m + 1 col = Cells(r, m).Column If col > 8 Then r = r + 1: m = 2 Next Erase Arab_day End Sub الملف مرفق My_Calendar.xlsm

تم معالجة الامر طلب شرح without_macro.xlsx

جرب هذا الملف طلب شرح Salim.xlsm

الصورة لا تجدي نفعاً يجب تحميل الملف نفسه(لا يمكن عمل معادلات على صورة) مع ذلك اليك هذا المثال (الصفحة ( salim(2) Book2_salim.xlsx

وهذه ايضاً (Ctrl+Shift+Enter) =INDEX($D$2:$D$14,MATCH(MAX(IF($A$2:$A$14=$H$9,ROW($A$2:$A$14))+IF($B$2:$B$14=$I$9,ROW($A$2:$A$14))),IF($A$2:$A$14=$H$9,ROW($A$2:$A$14))+IF($B$2:$B$14=$I$9,ROW($A$2:$A$14)),0))

لم افهم المقصود هل تريد اذا كان الرقم اصغر من5 يعطيك 0.5 و اذا اكبر يعطيك 1 و ما هو الحل اذا كان الرقم =5 على كل حال يمكن استعمال هذه المعادلة و التحكم باشارات > < و = ((IF(A2="","",CHOOSE((A2>=5)+1,1,0.5=

و هذه معادلة اخرى لنفس الغرض وذلك لاثراء الموصوع (Ctrl+Shift+Enter) معادلة صفيف =LOOKUP(MAX($D$2:$D$14)+1,IF($A$2:$A$14=$H$9,IF($B$2:$B$14=$I$9,$D$2:$D$14)))

يمكن استعمال هذا الكود (بدون حلقات تكرارية) Option Explicit Sub DEl_H_New() Dim Lh As Long Lh = Cells(Rows.Count, "H").End(3).Row If Lh < 4 Then Exit Sub Range("h4:h" & Lh).SpecialCells(4). _ EntireRow.Delete End Sub

تفضل هذا الملف المصنف1.rar

جرب هذا الملف filtter salim.xls

هذا الكود Sub DEl_H() Dim My_rg As Range, Lh As Long, i As Long Lh = Cells(Rows.Count, "H").End(3).Row If Lh < 3 Then Exit Sub Set My_rg = Range("h2:h" & Lh) For i = Lh To 2 Step -1 If Cells(i, "H") = vbNullString Then _ Cells(i, "H").EntireRow.Delete Next End Sub

تم عمل ذلك بواسطة الكود المصنف1 salim1.rar

ربما يكون الحل المصنف1 salim.xlsx

جرب هذا الكود استبدل الرقم 1 باسم الشيت Private Sub Combobox2_change() Dim x As Long Dim t Dim m x = (ComboBox2.Value) * 1 t = Application.Match(x, Sheets("1").Range("g5:g65636"), 0) m = Application.Index(Sheets("1").Range("g5:g65636"), t) Me.Textbox10.Value = m End Sub

ربما كان هذا البديل (كما تريد مع ادراج التاريخ أوتوماتيكياً بدون السبت والاحد فقط بعد تعيين السنة والشهر و الضغط على الزر المناسب) قمت يتغيير اسماء الصفحات وادراج صف فارغ قبل البيانات لحسن عمل الكود Salimكود استدعاء On One Page.rar

في اي صفحة من الصفحات اضغط على الزر Button10 لتحصل على النتيجة فوراً (مرتبة ابجدياً) في الصفحة Al_In_One توزيع الطلاب غلى الفصول Salimكود استدعاء.rar

كي يعمل الكود يجب الا يكون خلايا مدمجة في الجدول

لا أعلم اذا كان هناك طريقة او لا لكن تستطيع اذا اردت ان تخفي الاعمدة من ِA حتى H

ريما تحتاج الى هذا النموذج (يمكن ان تعدل على الماكرو كما تشاء) الماكرو Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("a1:d10")) Is Nothing Then With ActiveSheet .Unprotect .Cells.Locked = False For Each Cell In ActiveSheet.UsedRange If Cell.Value = "" Then Cell.Locked = False Else Cell.Locked = True End If Next Cell .Protect End With End If End Sub الملف protect entry.xlsm

See this Video https://www.youtube.com/watch?v=Be-sCy4nINo

جرب هذا الملف Scrolls_Bar salim.xlsx