اذهب الي المحتوي
أوفيسنا

سليم حاصبيا

أوفيسنا
  • Posts

    8,723
  • تاريخ الانضمام

  • Days Won

    262

كل منشورات العضو سليم حاصبيا

  1. تم التعديل على الملف بواسطة معادلة في العامود الأول بمجرد تغيير اي اسم في الشيت Minho فقط يتم التغيير في كل النطاقات و تتسري المعادلات الباقية كما تريدين الصورة المرفقة توضح ذلك أكرر التغيير في Minho فقط الملف مرفق للتجربة With_formula_New1.xlsm
  2. ارفعي ملف فيه القليل من البيانات (و إن كانت عشوائية) صفين لا تكفي لمعاينة عمل معادلة (10 صفوف اقل شيء) المعادلات في الملف الذي رفعته لك سابقاً محمية لعدم العيث بها عن طريق الخطأ - لذلك لا تستطعين التعديل عليها بينما في اي خلية اخرى يمنكنك عمل اي شيء تم النعديل على الأسماء المعادلات تعمل بشكل ممتاز في الملف الجدبد المرفق من قبلي (حسب الصورة) مرفق ملف جديد للتوضيح With_formula_New.xlsm
  3. جرب هذا الملف (من الارشيف القديم) يمكنك اضافة قدر ما تشاء من البيانات Working time.xlsx
  4. ضعي مكان 1 2 3 4.... الأسماء الجديدة للأعمدة (بالضبط دون مسافات زائدة او ناقصة أو تغيير بالخط Capital & Small)
  5. أولاً لم أر أي اعجاب لأي رد على موضوعاتك فهل النقر بزر الماوس على اعجاب شيء يأخذ وقتاً ثانيا أنا لا اتعامل مع اليوزرفورم (خبرتي متواضعة بهذا الشأن) ثالثاً يرجى ادراج المشاركة الأخيرة في موضوع مستقل لعل احدهم(من له الخبرة الواسعة في اليوزر) يريد ان يشارك في الأجابة
  6. لا تكتبي مجموع بل Sum او اي شيء احر باللغة الاجنبية Summation مثلاً على كل حال كتابة اي شيء لا يكون تاريخاً يتم تجاهله
  7. للمرة الالف ( عدم تسمية الأوراق باللغة العربية) صجيج ان لغتنتا هي لغة القرآن الكريم ولغة الضاد ومن أجمل لغات العالم ونحن نفتخر فيها لكن للأسف لا تصلخ 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
  8. ممكن تلافي مشكلة الأعمدة بأدراج الأرقام غلى شكل 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
  9. تم التعديل ملاحظة (أرقام الأعمدة يمكن ان لا تتطابق في صفخات 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
  10. كان من الواجب التوضيح في بادىء الأمر لعدم تضييع الوقت بأمور فائدة منها الكود الجديد 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
  11. هذا الكود يقوم بما يلزم تغيير اسماء الصفحات الى اللغة الأجنبية لحسن نسخ الكود ولصقه 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
  12. معك كل الحق أعتذر انا صراحة لم أجربها
  13. ممتازة منك صديقي رائد (لكنها تدرج المكرر في حال وجوده) هذه معادلة احرى (بردو تدرج المكرر في حال وجوده) (سبق وان قلت ان استعمال الدالة 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
  14. جرب هذا الكود 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
  15. جرب هذا الملف تم حماية الصفحة لعدم العيث بالمعادلات عن طريق الخطا (بدون باسورد) dATA_Ameel.xlsm
  16. تم انشاء ملف ل خر لمعالجة التاريخ Number_search_date.xlsm
  17. جرب هذا الملف العامود L اتركه فارغاً تماماً (حتى لا يؤثر على عمل الماكرو) MY_librery.xlsb لتعديل البيانات يمكنك راٍساُ تعديلها يدوياً ( بعد اجراء الفلتر) أو بواسطة ماكرو اخر
×
×
  • اضف...

Important Information