سليم حاصبيا

ريما كان المطلوب الفلترة فيتم الفصل بين كل فئة Salim.xls

انا ادخلت الخلية الثانية لغرض الاخنيار بين 10% 20% الح..... يمكن الاستغناء عن هذه الخلية اذا اردت نسبة مئوية ثابتة (او يمكن الكتابة فيها بشكل غير مرئي لاي شخص أو اخفائها)

لم ترفع ملفاً كمثال و لكني اتوقّع هذا النموذج Book1.xlsm

ليس عليك ان تنسخ و تلصق كل ما هو مطلوب كتابة البيانات في الورقة الاولى لتظهر لك او تو ماتكياً في الثانية(طبعاً مع عدم الغاء المعادلات)

ربما يكون الحل غياب.xlsx

تم التعديل على الملف من حيث وظيفة الزر Get _Facture في الصفحة Data يرجى اعادة التحميل Print_Issalate salim1.xlsm

بعد اذن اخي بن علية حل اخر يجمع اكثر من ايصال في ورقة واحد من اجل الطباعة استبدل في الكود السطر Sheets("Print").PrintPreview بالسطر Sheets("Print").PrintOut Print_Issalate salim.xlsm

ادراج رزنامة شهرية لسنة معينة و شهر معين (باختيارك) بدون يوم او يومين تحددهما بنفسك و اذا لم تحدد الايام (بمسح الخلايا المناسبة) يتم ادراج كامل الشهر Sub Give_date_without_same_days() With CommandButton1 .Left = 469: .Top = 18.5: .Width = 154.5 End With If Not IsNumeric([a2]) Or Not IsNumeric([b2]) _ Or [b2] < 1 Or [b2] > 12 _ Or IsEmpty([a2]) Or IsEmpty([b2]) Then MsgBox "أدخل أرقاماً صحيحة في الخلايا " & Chr(10) & "$ِِِA$2 and $B$2 " & Chr(10) _ & "وأعد المحاولة", vbOKOnly + vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "!...ٍSalim" Range("c4:Ag5").ClearContents Range("c4:Ag5").Borders.LineStyle = 0 GoTo Exit_Me End If With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlManual End With Dim Array_Days(), My_Days_Arabic() Dim Arab_Day(), My_Date_For_Print() Dim Array_Numbers() Dim t As Date, i%, k%, m%, x%, last_col% Dim y$ '============================== Array_Days = Array("sun", "mon", "tue", "wed", "thu", "fri", "sat") Arab_Day = Array("الأحد", "الإثنين", "الثلاثاء", "الأربعاء", "الخميس", "الجمعة", "السّبت") Array_Numbers = Array(1, 2, 3, 4, 5, 6, 7) last_col = Cells(5, Columns.Count).End(1).Column Range("c4").Resize(2, last_col).ClearContents Range("c4").Resize(2, last_col).Borders.LineStyle = 0 '================================= [a2] = Int([a2]): [b2] = Int([b2]) t = DateSerial([a2], [b2], 1) x = Day(Application.EoMonth(t, 0)) k = 1 For i = 1 To x y = Application.Index(Arab_Day, Application.Match(Weekday(t), Array_Numbers, 0)) If Trim(y) = Trim([d2].Value) Or _ Trim(y) = Trim([e2].Value) Then GoTo 2 ReDim Preserve My_Days_Arabic(1 To k): My_Days_Arabic(k) = y ReDim Preserve My_Date_For_Print(1 To k): My_Date_For_Print(k) = t k = k + 1 ' End If 2: t = t + 1 Next Range("C4").Resize(1, UBound(My_Days_Arabic)) = My_Days_Arabic Range("C5").Resize(1, UBound(My_Date_For_Print)) = My_Date_For_Print Range("C4").Resize(2, UBound(My_Days_Arabic)).Borders.LineStyle = 1 ActiveSheet.PageSetup.PrintArea = "" ActiveSheet.PageSetup.PrintArea = Range("a1").Resize(6, UBound(My_Days_Arabic) + 2).Address Exit_Me: Erase Array_Days: Erase Arab_Day: Erase Array_Numbers With Application .ScreenUpdating = True .Calculation = xlAutomatic .EnableEvents = True End With End Sub Private Sub CommandButton1_Click() Give_date_without_same_days End Sub Private Sub Worksheet_Activate() With CommandButton1 .Left = 469: .Top = 18.5: .Width = 154.5 End With End Sub الكود موجود ضمن الملف Date_sans_deux_jours.xlsm

الحل هنا هل من الضروري رفع هذه الكمية الصخمة(6500 صف) من البيانات 2018 salim.xlsx

المطلوب غير واضح تماماً

ارفع مثالاً (حوالي 20 سطر للعمل عليه)

هذا الكود Sub Print_Salim() Dim range_to_Print As Range Dim k% Set range_to_Print = Range("A6").Resize(Range("V1") - 5, 11) Application.ScreenUpdating = False X = Application.CountA(Range("m1:m7")) For I = 1 To X k = 2 range_to_Print.EntireRow.Hidden = False Cells(1, 6) = Application.Index(Range("m1:m6"), I) Do Until range_to_Print.Cells(k, 1) = "" If range_to_Print.Cells(k, 11) <> Cells(1, 6) Then _ range_to_Print.Cells(k, 1).EntireRow.Hidden = True k = k + 1 Loop ActiveSheet.PageSetup.PrintArea = _ range_to_Print.SpecialCells(12).Address '=================== يمكنك اختيار احد هذين الامرين أو كلاهما ============== 'ActiveWindow.SelectedSheets.PrintPreview 'ActiveWindow.SelectedSheets.PrintOut Copies:=1 '=========================================================== Next Application.ScreenUpdating = True End Sub الملف مرفق ‏‏‏رصد الإتقان salim.rar

تم معالجة الامر الاوائل salim__.xlsx

لم افهم ما تريد بالضيط رجاء اعمل جدول بالنتائج المتوقعة و ارفع الملف من جديد (بدون زوزقة اي الوان تبهر النظر)

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

لو فرضنا ان البيانات في العامود ِA هذه المعادلة تفي بالمطلوب (مع السحب نزولاً قدر ما تريد) =IF(ROWS($A$1:A1)>(COUNTA(A:A))/2,"",INDEX(A:A,2*(ROWS($A$1:A1)-1)+1))

في حال الرغبة في جمع بشكل عمودي هذه المعادلة في B6 والسجب يميناً =IF(N(B$1)=0,"",SUMPRODUCT(--(B$2:B$5="N")*16)+SUMPRODUCT(--(B$2:B$5="D")*8))

الملف يصيغة 2003 مواظبة sailim 2003.xls

بالنسبة لعرض الاسماء حسب الفصول اليك هذا الكود (اسرع بكثير لانه يعتمد على فلترة البيانات بدون حلقات تكرارية) و يضع لك قي اسفل 3 صفوف ما تريده Option Explicit Sub Slim_Data() Dim data As Worksheet, Ws As Worksheet Dim Old_lr As Long Dim New_lr As Long Dim last_row1% With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False End With Set data = Sheets("السجل") Set Ws = Sheets("مواظبة") Ws.Range("iv1") = "اسم الفصل" Ws.Range("iv2") = Ws.Range("ah2") Old_lr = Ws.Cells(Rows.Count, 2).End(3).Row Ws.Range("a7:Aj" & Old_lr).ClearContents last_row1 = data.Range("c10").CurrentRegion.Rows.Count + 9 Dim Tabl As Range: Set Tabl = data.Range("c10:l" & last_row1) If data.FilterMode = True Then data.ShowAllData Tabl.AdvancedFilter Action:=1, criteriarange:=Ws.Range("Iv1:Iv2") Tabl.Columns(2).Copy Ws.Range("b6") data.ShowAllData New_lr = Ws.Cells(Rows.Count, 2).End(3).Row + 3 Ws.Range("a7:Aj" & New_lr).Borders.LineStyle = 1 With Ws.Range("a7") .Value = 1: .Resize(New_lr - 9).DataSeries Step:=1 End With With Ws.Range("b" & New_lr) .Offset(-2, 0) = "مقيّد" .Offset(-1, 0) = "حاضر" .Value = "غائب" End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True End With End Sub اما بالنسبة للتاريخ دون السبت والاحد فقد كانت لي مشاركة يهذا الموضوع قد ارسلتها لك الملف مواظبة sailim.xlsm

في الخلية H2 اكتب هذا المعادلة واسحب نزولاَ =IF($A2="","",SUMPRODUCT(--($B2:$F2="N")*16)+SUMPRODUCT(--($B2:$F2="D")*8))

ممكن ان يكون هذا الماكرو هو الحل (تم تغيير اسماء الصفحات لحسن عمل الكود) Option Explicit Sub filter_for_ME() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim lr_T_sh% Dim S_sh As Worksheet: Set S_sh = Sheets("Source_sheet") Dim T_sh As Worksheet: Set T_sh = Sheets("Target_sheet") Dim My_Table As Range: Set My_Table = S_sh.Range("b2").CurrentRegion T_sh.Range("b7").CurrentRegion.Borders.LineStyle = 0 T_sh.Range("b7").CurrentRegion.Interior.ColorIndex = 0 T_sh.Range("b7").CurrentRegion.ClearContents T_sh.Range("t2").Formula = _ "=AND(B2<=Target_sheet!$C$3,B2>=Target_sheet!$C$2,E2=Target_sheet!$E$2,C2=Target_sheet!$D$2)" My_Table.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=T_sh.Range("t1:t2"), _ CopyToRange:=T_sh.Range("b6:h6") T_sh.Range("t2").ClearContents lr_T_sh = T_sh.Range("b7").CurrentRegion.Rows.Count + 5 If lr_T_sh = 7 Then With Range("b6:H6") .Interior.ColorIndex = 0 .ClearContents .Borders.LineStyle = 0 End With MsgBox "No Data to Extract" Else T_sh.Range("b7:h" & lr_T_sh).Interior.ColorIndex = 6 End If With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق Book3330 Salim.xlsm

كي يعمل الكوط للتصقيى يجب ان تكون كل كلمة من محتويات الصف الاول من الجدول مطابقة تماماً(حتى المسافات بين الكلمات) لما يقابلها في الجدول الثاني و هذا لا الاحظه في الجدولين جرب قبل كل شيء هذه المعادلة في الحلية A3 من الورقة الاولى وانسخها الى الصف كله فلا ترى الا True واجدة =OR(A4=Copy!$A$1:$AF$1)

جرب هذا الملف time and date.xlsm

للاختصار اكثر واكثر Option Explicit Option Base 1 Sub My_Calandar3() 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 t = t + 1 m = m + 1 r = IIf(m > 8, r + 1, r) m = IIf(m > 8, 2, m) End With Next Range("b5:h9").SpecialCells(2).Interior.ColorIndex = 35 Range(Range("b5:h9").Find(Search_Day).Address).Interior.ColorIndex = 3 Erase Arab_day End Sub

تفضل الملف مع المعادلة اخر شراء Salim.xlsx