سليم حاصبيا

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

تم التعديل على الملف بواسطة معادلة في العامود الأول بمجرد تغيير اي اسم في الشيت Minho فقط يتم التغيير في كل النطاقات و تتسري المعادلات الباقية كما تريدين الصورة المرفقة توضح ذلك أكرر التغيير في Minho فقط الملف مرفق للتجربة With_formula_New1.xlsm

ارفعي ملف فيه القليل من البيانات (و إن كانت عشوائية) صفين لا تكفي لمعاينة عمل معادلة (10 صفوف اقل شيء) المعادلات في الملف الذي رفعته لك سابقاً محمية لعدم العيث بها عن طريق الخطأ - لذلك لا تستطعين التعديل عليها بينما في اي خلية اخرى يمنكنك عمل اي شيء تم النعديل على الأسماء المعادلات تعمل بشكل ممتاز في الملف الجدبد المرفق من قبلي (حسب الصورة) مرفق ملف جديد للتوضيح With_formula_New.xlsm

جرب هذا الملف (من الارشيف القديم) يمكنك اضافة قدر ما تشاء من البيانات Working time.xlsx

ضعي مكان 1 2 3 4.... الأسماء الجديدة للأعمدة (بالضبط دون مسافات زائدة او ناقصة أو تغيير بالخط Capital & Small)

تم حل المشكلة dATA_Ameel _(1).xlsm

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

لا تكتبي مجموع بل Sum او اي شيء احر باللغة الاجنبية Summation مثلاً على كل حال كتابة اي شيء لا يكون تاريخاً يتم تجاهله

لا أرى اي كلمة محموع في minho و لا في laho

تم معالحة الأمر dATA_Ameel _Updated.xlsm

للمرة الالف ( عدم تسمية الأوراق باللغة العربية) صجيج ان لغتنتا هي لغة القرآن الكريم ولغة الضاد ومن أجمل لغات العالم ونحن نفتخر فيها لكن للأسف لا تصلخ 100% للمعادلات والأكواد في اكسل (نسبة الخطأ تتعدى ال 90%) جربي كتابة اسم اي ورقة باللغة العربية وانظري مذا يجري تم حل الموضوع بالمعادلات (المعادلات محمية / ضد الكتابة فوقها / لعدم العيث بها عن طريق الخطا زلكنها ليست محمية ضد الحذف) المعادلة في الخلية C3 مع (Ctl+Shift+Enter) والسحب نزولاُ حتى الخلية C25 و لذلك الأمر بالنسبة للخلية D3 مع تغيير اسم الصفحة داخل المعادلة =SUM((Minho!$A$2:$A$1000>=$E$2)*(Minho!$A$2:$A$1000<=$F$2)*(INDIRECT("Minho!"&ADDRESS(2,(MATCH($A3,Minho!$A$1:$AA$1)),1)&":"&ADDRESS(1000,(MATCH($A3,Minho!$A$1:$AA$1)),1)))) With_formula.xlsm

تم التعديل (بالمعادلات صعبة قوي) From_To Rows_Columns_Adv.xlsm

ممكن تلافي مشكلة الأعمدة بأدراج الأرقام غلى شكل X/y حيث تدل X على الصفحة "Minho" و y تدل على الصفخة "Laho" و في حال كان الرقم منفرداً يكون في الصفحة "Minho" تعديل الكود Option Explicit Sub Extact_Data_By_Columns() Rem Created By Salim Hasbaya on 29/5/2020 Application.ScreenUpdating = False Dim M As Worksheet, L As Worksheet, R As Worksheet Dim Rg_M As Range, Rg_L As Range Dim I%, Lr_M%, Lr_L%, RO%, it Dim St_Date As Date, End_Date As Date Dim arr, My_sum#, My_count% Set M = Sheets("Minho"): Set L = Sheets("Laho") Set R = Sheets("Repport") Lr_M = M.Cells(Rows.Count, 1).End(3).Row Lr_L = L.Cells(Rows.Count, 1).End(3).Row R.Range("A2").Resize(26, 3).ClearContents If Not IsDate(R.Range("D2")) Or Not IsDate(R.Range("D2")) Then _ MsgBox "Type Please Correct Dates In The Cells D2 and E2 ": GoTo Leave_Me_Olone St_Date = Application.Min(R.Range("D2:E2")) End_Date = Application.Max(R.Range("D2:E2")) ReDim arr(1 To 26) For I = 1 To 26 arr(I) = I Next '++++++++++++++++++++++++++++++++++++++++ With M .Range("A2:AC" & Lr_M).Interior.ColorIndex = xlNone For I = 2 To Lr_M If .Cells(I, 1) <= End_Date _ And .Cells(I, 1) >= St_Date Then .Cells(I, 1).Resize(, 29).Interior.ColorIndex = 6 End If Next I End With ''++++++++++++++++++++++++++++++++ With L .Range("A2:AC" & Lr_L).Interior.ColorIndex = xlNone For I = 2 To Lr_L If .Cells(I, 1) <= End_Date _ And .Cells(I, 1) >= St_Date Then .Cells(I, 1).Resize(, 29).Interior.ColorIndex = 6 End If Next I End With RO = 2 '++++++++++++++++++++++++++++++++++++++++ With M For Each it In arr My_count = Application.CountA(.Cells(2, it + 3).Resize(Lr_M - 1)) If My_count = 0 Then GoTo NexT_it For I = 2 To Lr_M If .Cells(I, it + 3).Interior.ColorIndex = 6 Then My_sum = My_sum + _ IIf(IsNumeric(.Cells(I, it + 3)), .Cells(I, it + 3), 0) If .Cells(I, it + 3) <> vbNullString Then .Cells(I, it + 3).Interior.ColorIndex = 35 End If End If Next I R.Cells(RO, 1) = it: R.Cells(RO, 2) = _ IIf(My_sum <> 0, My_sum, vbNullString) My_sum = 0: RO = RO + 1 NexT_it: Next it End With '++++++++++++++++++++++++++++++++++++ RO = 2: My_sum = 0 With L For Each it In arr My_count = Application.CountA(.Cells(2, it + 3).Resize(Lr_L - 1)) If My_count = 0 Then GoTo NexT_itm For I = 2 To Lr_L If .Cells(I, it + 3).Interior.ColorIndex = 6 Then My_sum = My_sum + _ IIf(IsNumeric(.Cells(I, it + 3)), .Cells(I, it + 3), 0) If .Cells(I, it + 3) <> vbNullString Then .Cells(I, it + 3).Interior.ColorIndex = 35 End If End If Next I R.Cells(RO, 1) = _ IIf(R.Cells(RO, 1) = vbNullString, it, it & " \ " & R.Cells(RO, 1)) R.Cells(RO, 3) = _ IIf(My_sum <> 0, My_sum, vbNullString) My_sum = 0: RO = RO + 1 NexT_itm: Next it End With '++++++++++++++++++++++++++++++++++++ Leave_Me_Olone: Application.ScreenUpdating = True End Sub

تم التعديل ملاحظة (أرقام الأعمدة يمكن ان لا تتطابق في صفخات Minho & Laha )لذلك يجب ادراج عامود اضافي لهذه الأرقام في صفحة Repport ) لا وقت لدي لعمل ذلك (تركت أرقام الأعمدة للصفخة Minho) Option Explicit Sub Extact_Data_By_Columns() Rem Created By Salim Hasbaya on 29/5/2020 Application.ScreenUpdating = False Dim M As Worksheet, L As Worksheet, R As Worksheet Dim Rg_M As Range, Rg_L As Range Dim I%, Lr_M%, Lr_L%, RO%, it Dim St_Date As Date, End_Date As Date Dim arr, My_sum#, My_count% Set M = Sheets("Minho"): Set L = Sheets("Laho") Set R = Sheets("Repport") Lr_M = M.Cells(Rows.Count, 1).End(3).Row Lr_L = L.Cells(Rows.Count, 1).End(3).Row R.Range("A2").Resize(26, 3).ClearContents If Not IsDate(R.Range("D2")) Or Not IsDate(R.Range("D2")) Then _ MsgBox "Type Please Correct Dates In The Cells D2 and E2 ": GoTo Leave_Me_Olone St_Date = Application.Min(R.Range("D2:E2")) End_Date = Application.Max(R.Range("D2:E2")) ReDim arr(1 To 26) For I = 1 To 26 arr(I) = I Next '++++++++++++++++++++++++++++++++++++++++ With M .Range("A2:AC" & Lr_M).Interior.ColorIndex = xlNone For I = 2 To Lr_M If .Cells(I, 1) <= End_Date _ And .Cells(I, 1) >= St_Date Then .Cells(I, 1).Resize(, 29).Interior.ColorIndex = 6 End If Next I End With ''++++++++++++++++++++++++++++++++ With L .Range("A2:AC" & Lr_L).Interior.ColorIndex = xlNone For I = 2 To Lr_L If .Cells(I, 1) <= End_Date _ And .Cells(I, 1) >= St_Date Then .Cells(I, 1).Resize(, 29).Interior.ColorIndex = 6 End If Next I End With RO = 2 '++++++++++++++++++++++++++++++++++++++++ With M For Each it In arr My_count = Application.CountA(.Cells(2, it + 3).Resize(Lr_M - 1)) If My_count = 0 Then GoTo NexT_it For I = 2 To Lr_M If .Cells(I, it + 3).Interior.ColorIndex = 6 Then My_sum = My_sum + _ IIf(IsNumeric(.Cells(I, it + 3)), .Cells(I, it + 3), 0) If .Cells(I, it + 3) <> vbNullString Then .Cells(I, it + 3).Interior.ColorIndex = 35 End If End If Next I R.Cells(RO, 1) = it: R.Cells(RO, 2) = IIf(My_sum <> 0, My_sum, vbNullString) My_sum = 0: RO = RO + 1 NexT_it: Next it End With '++++++++++++++++++++++++++++++++++++ RO = 2: My_sum = 0 With L For Each it In arr My_count = Application.CountA(.Cells(2, it + 3).Resize(Lr_L - 1)) If My_count = 0 Then GoTo NexT_itm For I = 2 To Lr_L If .Cells(I, it + 3).Interior.ColorIndex = 6 Then My_sum = My_sum + _ IIf(IsNumeric(.Cells(I, it + 3)), .Cells(I, it + 3), 0) If .Cells(I, it + 3) <> vbNullString Then .Cells(I, it + 3).Interior.ColorIndex = 35 End If End If Next I R.Cells(RO, 3) = IIf(My_sum <> 0, My_sum, vbNullString) My_sum = 0: RO = RO + 1 NexT_itm: Next it End With '++++++++++++++++++++++++++++++++++++ Leave_Me_Olone: Application.ScreenUpdating = True End Sub الملف( للمرة الثّالثة) From_To Row_Column_1.xlsm

كان من الواجب التوضيح في بادىء الأمر لعدم تضييع الوقت بأمور فائدة منها الكود الجديد Option Explicit Sub Extarct_Data_By_Columns() Rem Created By Salim Hasbaya on 29/5/2020 Dim M As Worksheet, L As Worksheet, R As Worksheet Dim Rg_M As Range, Rg_L As Range Dim I%, Lr_M%, Lr_L%, RO%, it Dim St_Date As Date, End_Date As Date Dim arr, My_sum# Set M = Sheets("Minho"): Set L = Sheets("Laho") Set R = Sheets("Repport") Lr_M = M.Cells(Rows.Count, 1).End(3).Row Lr_L = L.Cells(Rows.Count, 1).End(3).Row R.Range("B2").Resize(25, 2).ClearContents If Not IsDate(R.Range("D2")) Or Not IsDate(R.Range("D2")) Then _ MsgBox "Type Please Correct Dates In The Cells D2 and E2 ": Exit Sub St_Date = Application.Min(R.Range("D2:E2")) End_Date = Application.Max(R.Range("D2:E2")) ReDim arr(1 To 25) For I = 1 To 25 arr(I) = I + 3 Next '++++++++++++++++++++++++++++++++++++++++ With M .Range("A2:AC" & Lr_M).Interior.ColorIndex = xlNone For I = 2 To Lr_M If .Cells(I, 1) <= End_Date _ And .Cells(I, 1) >= St_Date Then .Cells(I, 1).Resize(, 29).Interior.ColorIndex = 6 End If Next I End With ''++++++++++++++++++++++++++++++++ With L .Range("A2:AC" & Lr_L).Interior.ColorIndex = xlNone For I = 2 To Lr_L If .Cells(I, 1) <= End_Date _ And .Cells(I, 1) >= St_Date Then .Cells(I, 1).Resize(, 29).Interior.ColorIndex = 6 End If Next I End With RO = 2 With M For Each it In arr For I = 2 To Lr_M If .Cells(I, it).Interior.ColorIndex = 6 Then My_sum = My_sum + _ IIf(IsNumeric(.Cells(I, it)), .Cells(I, it), 0) End If Next I R.Cells(RO, 2) = IIf(My_sum > 0, My_sum, vbNullString) My_sum = 0: RO = RO + 1 Next it End With '++++++++++++++++++++++++++++++++++++ RO = 2: My_sum = 0 With L For Each it In arr For I = 2 To Lr_M If .Cells(I, it).Interior.ColorIndex = 6 Then My_sum = My_sum + _ IIf(IsNumeric(.Cells(I, it)), .Cells(I, it), 0) End If Next R.Cells(RO, 3) = IIf(My_sum > 0, My_sum, vbNullString) My_sum = 0: RO = RO + 1 Next End With '++++++++++++++++++++++++++++++++++++ End Sub المرفق من جديد (الماكرو الاول ما زال يعمل اذا لزم الأمر باستعماله) From_To Row_Col.xlsm

هذا الكود يقوم بما يلزم تغيير اسماء الصفحات الى اللغة الأجنبية لحسن نسخ الكود ولصقه Option Explicit Sub Extarct_Data() Rem Created By Salim Hasbaya on 29/5/2020 Dim M As Worksheet, L As Worksheet, R As Worksheet Dim Rg_M As Range, Rg_L As Range Dim I%, Lr_M%, Lr_L%, RO% Dim St_Date As Date, End_Date As Date Set M = Sheets("Minho"): Set L = Sheets("Laho") Set R = Sheets("Repport") Lr_M = M.Cells(Rows.Count, 1).End(3).Row Lr_L = L.Cells(Rows.Count, 1).End(3).Row R.Range("B2").Resize(25, 2).ClearContents If Not IsDate(R.Range("D2")) Or Not IsDate(R.Range("D2")) Then _ MsgBox "Type Please Correct Dates In The Cells D2 and E2 ": Exit Sub St_Date = Application.Min(R.Range("D2:E2")) End_Date = Application.Max(R.Range("D2:E2")) '++++++++++++++++++++++++++++++++++++++++ With M .Range("A2:AC" & Lr_M).Interior.ColorIndex = xlNone RO = 2 For I = 2 To Lr_M If .Cells(I, 1) <= End_Date _ And .Cells(I, 1) >= St_Date Then .Cells(I, 1).Resize(, 29).Interior.ColorIndex = 6 R.Cells(RO, 2) = Application.Sum(.Cells(I, 4).Resize(, 26)) RO = RO + 1 End If Next I End With '++++++++++++++++++++++++++++++++ With L .Range("A2:AC" & Lr_L).Interior.ColorIndex = xlNone RO = 2 For I = 2 To Lr_L If .Cells(I, 1) <= End_Date _ And .Cells(I, 1) >= St_Date Then .Cells(I, 1).Resize(, 29).Interior.ColorIndex = 6 R.Cells(RO, 3) = Application.Sum(.Cells(I, 4).Resize(, 26)) RO = RO + 1 End If Next I End With End Sub الملف مرفق From_To.xlsm

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

معك كل الحق أعتذر انا صراحة لم أجربها

تفضل لكن في مشاركة مستقلة

ممتازة منك صديقي رائد (لكنها تدرج المكرر في حال وجوده) هذه معادلة احرى (بردو تدرج المكرر في حال وجوده) (سبق وان قلت ان استعمال الدالة IFERROR ) يفضل عدم استعمالها =IF(ROWS($A$1:A1)>SUMPRODUCT(--(YEAR($B$2:$B$50)=$G$1)),"",INDEX($A$2:$A$50,SMALL(IF($A$2:$A$50<>"",IF(YEAR($B$2:$B$50)=$G$1,ROW($A$2:$A$50)-ROW($A$2)+1)),ROWS($A$1:A1)))) اذا لم نتعمل معك استبدل الفاصلة "," بفاصلة منقوطة ";" مع (Ctrl+Shift+Enter) Prof_names.xlsm

جرب هذا الكود Option Explicit Sub get_Prof_names() Dim sh As Worksheet, Rg As Range Dim i%, Yer% Dim Salim As Object Set Salim = CreateObject("Scripting.Dictionary") Set sh = Sheets("sheet1") Set Rg = sh.Range("G3").CurrentRegion If Rg.Rows.Count > 1 Then _ Rg.Offset(1).Resize(Rg.Rows.Count - 1).Clear Yer = sh.Range("G1"): i = 2 Do Until sh.Cells(i, 1) = vbNullString If Year(Cells(i, 2)) = Yer Then Salim(Cells(i, 1).Value) = vbNullString End If i = i + 1 Loop If Salim.Count Then With sh.Range("G4").Resize(Salim.Count) .Value = Application.Transpose(Salim.Keys) .Borders.LineStyle = 1 .Font.Bold = True: .Font.Size = 16 .InsertIndent 1: .Interior.ColorIndex = 35 End With End If End Sub الملف مرفق Prof_names.xlsm

جرب هذا الملف تم حماية الصفحة لعدم العيث بالمعادلات عن طريق الخطا (بدون باسورد) dATA_Ameel.xlsm

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

تم انشاء ملف ل خر لمعالجة التاريخ Number_search_date.xlsm

جرب هذا الملف العامود L اتركه فارغاً تماماً (حتى لا يؤثر على عمل الماكرو) MY_librery.xlsb لتعديل البيانات يمكنك راٍساُ تعديلها يدوياً ( بعد اجراء الفلتر) أو بواسطة ماكرو اخر