سليم حاصبيا

كيف نعرف كم يوم سبت أو أحد أو الخ.... بين تاريخين (دون ماكرو) هذا الملف يوضح كل شيء (الباسوورد فيما بعد لمعرفة كل الاقتراحات) how many_days.xlsx

الكثيرون لحماية الخلايا يستعملون حماية الشيت (Protect Sheet) لكن في نطاق معين (تختاره بواسطة الكود) كيف يمكن ان نستعمل الخلية مرة واحدة فقط بحيث لا يمكن مسحها ولا التعديل عليها فيما بعد الا اذا تم توقيف الكود عن العمل كل ذلك بدون ( Protect Sheet) الكود Option Explicit Dim Old_value Dim New_value Private Sub Worksheet_SelectionChange(ByVal Target As Range) Old_value = Target.Cells(1, 1).Value End Sub '============================================== Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False On Error GoTo Final_Step If Intersect(Target, Range("A1:F12")) Is Nothing Then GoTo Final_Step New_value = Target.Value If Old_value = "" And Target.Cells.Count > 1 Then Application.Undo GoTo Final_Step End If If Old_value = "" Then Target.Value = New_value Else Application.Undo End If Final_Step: Application.EnableEvents = True End Sub الملف تحت التصّرف Protect_without Protect.xlsm

تهمل الخلايا الفارغة و ليس المسافات (لان المسافة لا تعتبر فراغاً)

الملف جاهز أهم شيء الا يكون داخل الجدول اي خلية فارغة و كذلك في راس الجدول Salim_book.xlsm

الماكرو المطلوب مبدئياً انقل الداتا الى صفجة مستقلة (انشاء صفحة جديدية) نفذ عليها ها الماكرو (يجب ان تيدأ البيانات من الخلية B4 قي المعادلة التي كتبتها انا يوجد * يجب وضعها حتى تعمل الدالة بشكل جيد لان الدالة (عند اسنعمال &) نتظر الى الرفمين 211 و 55 ( 55211) و تنطر الى الرقمين 11 و 552 (55211) اي نفس الشيء بنما عند استعمال النجمة يصبحون هكذا (211*55) و (11*552) مختلفين Option Explicit Sub Del_row() Dim i As Long Dim lr As Long: lr = Cells(Rows.Count, 2).End(3).Row On Error Resume Next ActiveSheet.ShowAllData On Error GoTo 0 Range("k4") = "salim" Range("k5:k" & lr).Formula = "=SUMPRODUCT(--(c5&d5&e5&f5&g5&h5=$c$5:c5&$d$5:d5&$e$5:e5&$f$5:f5&$g$5:g5&$h$5:h5))" Range("k5:k" & lr).Value = Range("k5:k" & lr).Value Range("M2").Formula = "=K5<>1" Range("k5:k" & lr).AdvancedFilter xlFilterInPlace, criteriarange:=Range("M1:M2") Range("k5:k" & lr).SpecialCells(12).EntireRow.Delete On Error Resume Next ActiveSheet.ShowAllData On Error GoTo 0 Range("k4:k" & lr).Clear: Range("m2").Clear End Sub

تم التعديل كما تريد الكود Option Explicit Sub romove_dup() Sheets("LIST").Range("z1").CurrentRegion.Clear Sheets("LIST").Range("A1", Sheets("LIST").Range("a1").End(4).End(2)).Copy _ Sheets("LIST").Range("Z1") Sheets("LIST").Range("z1", Sheets("LIST").Range("z1").End(4).End(2)).RemoveDuplicates _ Columns:=Array(1, 2, 3) Sheets("LIST").Range("z1", Sheets("LIST").Range("z1").End(4).End(2)) _ .SortSpecial End Sub '======================================= Private Sub ComboBox1_Change() Application.ScreenUpdating = False Dim x%, i%, My_Max%, My_Min% ComboBox2.Clear ComboBox3.Clear romove_dup Dim R% Dim My_rg Set My_rg = Sheets("LIST").Range("z1", Sheets("LIST").Range("z1").End(4)) R = My_rg.Find(ComboBox1.Text).Row Do Until My_rg.Cells(R).Value <> ComboBox1.Value ComboBox2.AddItem My_rg.Cells(R).Offset(, 1) R = R + 1 Loop Sheets("LIST").Range("z1").CurrentRegion.Clear My_Max = Application.Max(Sheets("LIST"). _ Range("c1", Sheets("LIST").Range("c1").End(4))) My_Min = Application.Min(Sheets("LIST"). _ Range("c1", Sheets("LIST").Range("c1").End(4))) x = My_Max - My_Min For i = 0 To x ComboBox3.AddItem My_Min + i Next ComboBox2.Value = "Choose Day" ComboBox3.Value = "Choose Year" Set My_rg = Nothing Application.ScreenUpdating = True End Sub الملف مرفق COMB_SALIM_Without _Rep.xlsm

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

تقضل الملف MOKARAR.xlsx

واضح جداً من اللائحة ان هناك بعض الاسماء التي تسيقها مسافات زائدة مثلا سامر في اول السطر بينما كريم قبله مسافة او ربما مسافتين ابظر بعد ازالة هذه المسافات With_2 ابجدي.xlsx

قصدي ترسل جداول فارغة و تطلب المساعدة و لبس هناك من تفاصيل ما هي الاقسام مثلاً؟؟؟

انا شخصياً لا أجيد التعامل مه جداول فارغة

بارك الله فيك اخي علي لكن السؤال كان ان تدرج كل النتائج في خلية واحدة بالنسبة للمعادلات عندك فهي رائعة لكن اسمج لي بهذا التعديل في الاعمدة H & I & J 1-اذ لا ضرورة لادراج معادلة خاصة في كل عامود منها معادلة واحدة (تكفي) تكتب في H5 وتسحب يساراً و نزولاً (Ctlr+Shift+Enter) 2-تصغير حجم نطاق البحث للدالة Index من 3 أعمدة ( C & D & E ) الى عامود واحد ( C) ثم (D) ثم (E) 3 - مغادلة IFERROR انا لا احبذها لانها تلزم الاكسل على اجراء العمليات الحسابية أولاً ثم اذا كان هناك خطأ يعطينا فراغ لذلك اسعمال if rows()> countif افضل لانه عندما يتجاوز عدد الصفوف حد معين ( في هذه الحالة كم مرة وردت خضروات في النطاق) يتوقف اكسل عن حساب المغادلة و يغطي فراغ رأساً مما يوفر اعباء اضافية على البرنامج وزيادة في حجم الملف دون سبب لذلك انصح دائما ياسنعمال if rows()> countif بدل IFERROR الا اذا كان لا مفر من ذلك بعد كل هذا الشرح المعادلة =IF(ROWS(H$5:H5)>COUNTIF(C$5:C$100,$H$3),"",INDEX($B$5:$B$100,SMALL(IF(C$5:C$100<>"",IF(C$5:C$100=$H$3,ROW(C$5:C$100)-ROW(C$5)+1)),ROWS(H$5:H5))))

المعادلة لا تعطي عذة نتائج في خلية واحدة

استبدل الماكرو الى هذا Option Explicit Sub filter_More_critertias() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim laste_row, New_last_row% Dim S_sh As Worksheet: Set S_sh = Sheets("data") Dim T_sh As Worksheet: Set T_sh = Sheets("Summary") Dim My_Table As Range: Set My_Table = S_sh.Range("b5").CurrentRegion laste_row = T_sh.Cells(Rows.Count, 3).End(3).Row If laste_row < 5 Then laste_row = 4 T_sh.Range("q6").Formula = "=data!I6=1" My_Table.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=T_sh.Range("Q5:q6"), _ CopyToRange:=T_sh.Range("b" & laste_row + 1) '=============================== With T_sh .Range("q6").Clear .Columns("i").Clear .Sort.SortFields.Clear .Sort.SortFields.Add Key:=Range("H6") _ , SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _ "الاول,الثاني,الثالث", DataOption:=xlSortNormal With .Sort .SetRange Range("B5").CurrentRegion .Header = xlYes .Apply End With '======================= End With Remove_Dup New_last_row% = T_sh.Cells(Rows.Count, 3).End(3).Row If Cells(New_last_row, 3) = "رقم الحساب" Then Cells(New_last_row, 3).EntireRow.Delete End If '======================= With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub '======================= Sub Remove_Dup() Sheets("Summary").Range("b5").CurrentRegion.RemoveDuplicates _ Columns:=Array(2, 3, 4, 5, 6, 7), Header:=1 End Sub الملف Tarhil_Unique.xlsm حمّل جزء بسيط من الملف ( 10 الى 15 اسم فقط ) و ليس 1200 اسم لاجراء اللازم

حرب هذا الكود Option Explicit Sub giVe_data() Dim My_Sh As Worksheet Dim st$, MY_Rg As Range Dim final_row%, K%, i%, m%: m = 8 Dim result$ Set My_Sh = Sheets("ورقة1") With My_Sh .Range("h5:j5").ClearContents st = .Range("h3") final_row = .Cells(Rows.Count, "B").End(3).Row Set MY_Rg = .Range("c5:E" & final_row) For i = 1 To 3 For K = 5 To final_row If MY_Rg.Cells(K - 4, i) = st$ Then result = result & _ .Cells(MY_Rg.Cells(K - 4, i).Row, 2) & "-" End If Next If result <> "" Then .Cells(5, m) = Mid(result, 1, Len(result) - 1) End If m = m + 1 result = "" Next End With End Sub الملف مرفق Espece.xlsm

اعتقد انه لا ضرورة للترحيل من صفحة الترحيل لان الكود يقوم بترحيل كل شيء و يقوم بترتيبها بدل ان تقوم في كل مرة بالتبديل بين (الاول والثاني والثالث) في صفحة الترحيل ( اي اجراء حلقة تكرارية لتنفيذ ماكرو واحد 3 مرات متتالية) اما صفحة الترحيل اتركها لفرز البيانات بعد تنفيذ الماكرو تستطيع ان تذهب الى صفحة Summary و تجري هناك عملية Remove duplicates على كل الاعمدة ما عدا العامود الاول (حيث الترقيم) (يمكن تحرير ماكرو لهذا الغرض عند حذث Worksheet_Activate) او بواسطة زر يوضع في هذه الصفحة يقوم بهذا العمل الماكرو المطلوب Sub Remove_Dup() Sheets("Summary").Range("b5").CurrentRegion.RemoveDuplicates _ Columns:=Array(2, 3, 4, 5, 6, 7), Header:=1 End Sub

جرب هذا الملف هناك معادلة في الشيت "data" العامود "I" (مخفي) لا يجب ان تمسح لانها تحدد المكرر من غير المكرر (غير المكرر تعطيه رقم 1) على اساس هذا الرقم تتم الفلترة (عند الضغط على الزر Run من صفحة "data") الفلتر يتعامل رأساً مع الصفحة "data" و ينقل النتيجة الى الصفحة "Summary" الكود Option Explicit Sub filter_More_critertias() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim S_sh As Worksheet: Set S_sh = Sheets("data") Dim T_sh As Worksheet: Set T_sh = Sheets("Summary") Dim My_Table As Range: Set My_Table = S_sh.Range("b5").CurrentRegion T_sh.Range("b5").CurrentRegion.Clear T_sh.Range("q6").Formula = "=data!I6=1" My_Table.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=T_sh.Range("Q5:q6"), _ CopyToRange:=T_sh.Range("b5") '=============================== With T_sh .Range("q6").Clear .Columns("i").Clear .Sort.SortFields.Clear .Sort.SortFields.Add Key:=Range("H6") _ , SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _ "الاول,الثاني,الثالث", DataOption:=xlSortNormal With .Sort .SetRange Range("B5").CurrentRegion .Header = xlYes .Apply End With End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق ترحيل لورقة واحدة Salim.xlsm

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

يا اخي ارفع ملفاً يستطيع الانسان ان يفهم منه شيئاً مثلاً عندك جدول من صفين و كل اعمدته ابتداء من العامود الثالث تساوي صفر او فراغ ماذا تريدنا ان نعمل الرجاء رفع ملف جديد فيه بعض البيانات (10 15 سطر) مع شرح ما تريد و وضع جدول ( ثاني ) بالنتائج المتوقعة

المشكلة في اكسل انه لا يتعامل مع الهمزة (باللغة العربية بالشكل الذي نعرفه) ربما انه يعتبرها بعد حرف الميم مثلاً لذلك تحاشى وضع الهمزات في بداية الاسماء فهذه مشكلة من تصميم الاكسل الذي وضع اصلاً للغات الاجنبية

ارفع الملف للمعاينة (لا يمكن التعامل مه صورة)

الملف مع Sheet2 With_2ترتيب ابجدي.xlsx

استعمال الدالة Index لا تلزمك استعمال Ctrl+Shift+Enter اذا كانت وحيدة في Formula لكن اذا استعملت معها في نفس Formula دالات اخرى مثل If او Match يجب ادخال Ctrl+Shift+Enter مثلا : =IF(ROWS($A$1:A1)>$G$1,"",INDEX($A$1:$A$100,SMALL(IF($A$1:$A$100<>"",IF(MATCH($A$1:$A$100,$A$1:$A$100,0)=ROW($A$1:$A$100)-ROW($A$1)+1,ROW($A$1:$A$100)-ROW($A$1)+1)),ROWS($A$1:A1)))) واعتقد (لست متأكداً) ان استعمال Ctrl+Shift+Enter يسرع في عملية البحث اذا كان هناك الكثير من الصفوف (فوق الـ 500)

هذه المعادلة (Ctrl+Shift+Enter) =MAX(INDEX(INDIRECT($J$2),,1)) اذا لم تعمل بدل الفاصلة العادية الى فاصلة منقوطة لتصبح هكذا (لا تنس Ctrl+Shift+Enter) =MAX(INDEX(INDIRECT($J$2);;1))

قم بنحديد الصفحتين معاً و باشر بالكتاية الطريقة 1-افتح اي صفحة تريد 2-اضغط باستمرار على مفتاح Ctrl و حدد صفحة ثانية (او اكثر كما تريد) ثم اترك مفتاح Ctrl 3- كل ما تكتبة يظهر في الصغحات المجددة 5 -لالغاء تحديد محموعة صفحات حدد اي صفحة خارج هذه المجموعة او Right Click على اسم صفحة من المجموعة (تظهر لك نافذة ) اختر منها Ungroup