Jump to content

سليم حاصبيا

أوفيسنا
  • Content Count

    5,919
  • Joined

  • Last visited

  • Days Won

    112

سليم حاصبيا last won the day on May 1

سليم حاصبيا had the most liked content!

Community Reputation

4,186 Excellent

About سليم حاصبيا

  • Rank
    فريق الموقع
  • Birthday 03/08/1985

Profile Information

  • Gender (Ar)
    ذكر
  • Job Title
    استاذ ثانوي
  • Location
    beiruth
  • Interests
    eXCEL

Recent Profile Visitors

7,891 profile views
  1. في الخلية E4 هذه المعادلة ثم اسحب نزولاً =IF(COUNTIF($A$4:A4,A4)=SUMPRODUCT(($A$4:A4=A4)*($D$4:D4="تم التسديد")),"",COUNTIF($A$4:A4,A4)-SUMPRODUCT(($A$4:A4=A4)*($D$4:D4="تم التسديد"))) و اذا لم تعمل معك استبدل الفاصلة " , " بفاصلة منقوطة " ; " لتصبح هكذا =IF(COUNTIF($A$4:A4;A4)=SUMPRODUCT(($A$4:A4=A4)*($D$4:D4="تم التسديد"));"";COUNTIF($A$4:A4,A4)-SUMPRODUCT(($A$4:A4=A4)*($D$4:D4="تم التسديد"))) الملف مرفق Tasalsul.xlsx
  2. انا شخصياً لم افهم شيئاً رجاءً قم بوضع بعض البيانات (حوالي 5 صفوف) واكتب يدوياُ النتائج المتوقعة في الصفحتين
  3. في الملف 3 اوراق عن اي ورقة تتحدث و هل يمكن ادراج بعض البيانات
  4. تم معالجة الامر Option Explicit 'Created by Salim Hasbaya 2/5/2019 Sub New_tarhil() Application.ScreenUpdating = False Dim arr_s(1 To 11) Dim arr_t(1 To 11) Dim i%, RO_Num%, Final_Row% Dim RO_s% Dim RGS As Range Dim source_sh As Worksheet Set source_sh = Sheets("أدخال") 'from Dim target_sh As Worksheet Set target_sh = Sheets("اليومية") 'to '================================= RO_s = source_sh.Cells(Rows.Count, "A").End(3).Row + 1 If RO_s = 6 Then MsgBox "No Data To Transfer": GoTo LEAVE_ME_OUT RO_Num = source_sh.Range("a5"). _ CurrentRegion.Rows.Count Set RGS = source_sh.Range("a5"). _ CurrentRegion.Offset(1).Resize(RO_Num - 1) RO_Num = RGS.Rows.Count Final_Row = target_sh.Cells(Rows.Count, "D").End(3).Row + 1 '========================= For i = 1 To 11: arr_s(i) = i: Next For i = 1 To 3: arr_t(i) = i + 3: Next arr_t(4) = 9: arr_t(5) = 10 For i = 6 To 11: arr_t(i) = i + 8: Next For i = 1 To UBound(arr_s) target_sh.Rows(Final_Row). _ Cells(arr_t(i)).Resize(RO_Num).Value = _ RGS.Cells(1, arr_s(i)).Resize(RO_Num).Value Next Erase arr_t: Erase arr_s LEAVE_ME_OUT: Application.ScreenUpdating = True End Sub File Unclouded SAlim_ Prog_new1.xlsm
  5. استبدل الى هذا الماكرو Sub tarhel() Dim source_sh As Worksheet: Set source_sh = Sheets("أدخال") 'from Dim target_sh As Worksheet: Set target_sh = Sheets("اليومية") 'to Dim larow% larow = target_sh.Cells(Rows.Count, "D").End(3).Row + 1 If larow < 4 Then larow = 4 Dim RO_Num% RO_Num = source_sh.Range("a5").CurrentRegion.Rows.Count target_sh.Cells(larow, 4).Resize(RO_Num - 1, 11).Value = _ source_sh.Range("a6").Resize(RO_Num - 1, 11).Value End Sub و اضافة هذه المعادلة الى الى الخلية C4 من الورقة اليومية والسحب نزولاً =IF(D4="","",MAX($C$3:C3)+1) الملف مرفق SAlim_ Prog.xlsm
  6. الملف مضروب بفيروس و قد رفض الحهاز فتحه
  7. يجب ان تقوم بتسمية الصفحات تماماً كما في الملف المرفوع من قبلي و تأكد ان كلمات الأول / الثاني / الثالث مكتوبة بالضبط كما في الصفحات دون زيادة مسافات او نقصانها
  8. استاذ وجيه كود ممتاز ولكن ملاحظة بسيط تخفيفاً للكود ان بعض الورقات عير معنية بالكود مثل اخر ثلاث ورقات 1-لذلك لا لزوم لاجراء الحلقات التكرارية عليها (توفيراً للوقت وحجم الملف) 2- يمكن تلافي ذلك بادراج اسماء الصفحات المعنية ضمن Array والعمل على هذه الصفحات من خلال الـــ Array نفسه 3-بدل تكرار نفس السطر (مع تغيير العدد من 5 الى 12) في هذا الجزء من الكود '++++++++++++++++++++++++++++++++++++++++ Cells(k, 5) = Sheets(r).Cells(i, 5) Cells(k, 6) = Sheets(r).Cells(i, 6) Cells(k, 7) = Sheets(r).Cells(i, 7) Cells(k, 8) = Sheets(r).Cells(i, 8) Cells(k, 9) = Sheets(r).Cells(i, 9) Cells(k, 10) = Sheets(r).Cells(i, 10) Cells(k, 11) = Sheets(r).Cells(i, 11) Cells(k, 12) = Sheets(r).Cells(i, 12) '+++++++++++++++++++++++++++++++++++++++++++++ يمكن كتابة هذا القسم من الكود بهذا الشكل Dim x As Byte For x = 5 To 12 Cells(k, x) = Sheets(r).Cells(i, x) Next اما بالنسبة للسؤال الثاني يمكن عمل اوتو فلتر على الورقة فصول المدارس في عامود رقم اللجنة دون حلقات تكرارية (بعد اذنك طبعاً) ☺️
  9. الملف عندك كبير جداً 5 صفحات في 1200 صف مما لا يسهل عملية متابعة الكود دائماً وابداً ارجو منك ومن جميع من له مشاركات او اسئلة ان يرفق مثال مبسط عما يريدونه ،وذلك لوضع الكود المناسب و من ثم تعميمه على الملف الأصلي تم اختصار الملف الى حوالي 20 اسم في كل صفحة وتغيير اسماء الصفحات لسهولة عمل الكود (في حال اضافة مدارس جديدة) الكود (في حدث الصفحة فقط اختر الصف الذي تريده ليقوم الكود بغمله) Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$D$1" And Target.Count = 1 Then Copy_data End If Application.EnableEvents = True End Sub Rem======================== Rem======================== Rem======================== Sub Copy_data() Dim My_Sh As Worksheet Dim Arr(), i#, st Dim m#: m = 4 Dim x# Dim k As Byte: k = 1 Dim My_tabL As Range Set My_Sh = Sheets("FOUSUL") My_Sh.Range("a4:I" & Rows.Count).ClearContents st = My_Sh.[D1] For i = 1 To Sheets.Count If Mid(Sheets(i).Name, 1, 3) = "SHC" Then ReDim Preserve Arr(1 To k) Arr(k) = Sheets(i).Name k = k + 1 End If Next For k = LBound(Arr) To UBound(Arr) With Sheets(Arr(k)) If .FilterMode Then .ShowAllData .AutoFilterMode = False End If Set My_tabL = .Range("b3").CurrentRegion x = My_tabL.Rows.Count My_tabL.AutoFilter 5, st My_tabL.Offset(1).Resize(x - 1).SpecialCells(12).Copy _ My_Sh.Range("A" & m) m = My_Sh.Cells(Rows.Count, 2).End(3).Row + 1 If .FilterMode Then .ShowAllData .AutoFilterMode = False End If End With Next Erase Arr: Set My_tabL = Nothing End Sub الملف مرفق Mult_filtre _salim.xlsm
  10. بالنسبة للسؤال في أول مشاركة جرب الملف المرفق اما بالنسبة للمشاركات الباقية استعمل المعادلات التي ادرجها لك الاستاذ بن علية الكود للملف Option Explicit Private Sub COMBO_MADDA_DropButtonClick() Application.ScreenUpdating = False Dim Srs As Worksheet Dim Sal As Worksheet Dim i%, Lr_Srs Dim comBo_dic As Object Set comBo_dic = CreateObject("scripting.dictionary") Set Srs = Sheets("source"): Set Sal = Sheets("salim") Lr_Srs = Srs.Cells(Rows.Count, 1).End(3).Row For i = 3 To Lr_Srs If Not comBo_dic.exists((Srs.Range("b" & i).Value)) Then comBo_dic.Add Srs.Range("b" & i).Value, "" End If Next COMBO_MADDA.List = Application.Transpose(comBo_dic.keys) fil_COMBO_PROF Application.ScreenUpdating = True End Sub Sub fil_COMBO_PROF() Dim k%: k = 3 Dim x%: x = 1 Range("M4:M100").ClearContents Dim Arr() If Sheets("salim").Cells(2, 3) = vbNullString Then Exit Sub Do Until Sheets("source").Cells(k, 2) = vbNullString If Sheets("source").Cells(k, 2) = Sheets("salim").Cells(2, 3) Then ReDim Preserve Arr(1 To x) Arr(x) = Sheets("source").Cells(k, 1) x = x + 1 End If k = k + 1 Loop COMBO_PROF.List = Application.Transpose(Arr) COMBO_PROF.Value = Arr(1) Range("M4").Resize(x - 1) = Application.Transpose(Arr) Erase Arr End Sub Nitakat.xlsm
  11. جرب هذا الكود Option Explicit Sub Print_Areas() With Sheets("List") Dim lr%: lr = .Cells(Rows.Count, 1).End(3).Row With .PageSetup .PrintArea = Range("a1:I" & lr).Address .PrintTitleRows = "$1:$2" End With End With End Sub الملف مرفق ESSA_new.xls
  12. يمكن تعبئة الخلايا الفارغة بدون (Sort) ابجدياً بواسطة هذا الماكرو Option Explicit Sub give_Data() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim last_ro# last_ro = Range("a1").CurrentRegion.Rows.Count Range("MM2").Resize(last_ro - 1).Formula = _ "=IF(AND(C2<>"""",D2<>""""),D2,INDEX($D$2:$D$" & last_ro & ",MATCH(C2,$C$2:$C$" & last_ro & ",0))" & ")" Range("D2").Resize(last_ro - 1).Value = _ Range("MM2").Resize(last_ro - 1).Value Range("MM2").Resize(last_ro - 1) = vbNullString With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق FiLL_Empty.xlsm
  13. من أول نظرة الى الملف لاجظت ان تتابع الأسماء المكررة لذلك اقترحت هذا الماكرو اذا لم تكن الأسماء المكررة متتابعة بجب اولا ترتيبها (Sort) ابجدياً ثم ينفذ الماكرو
  14. جرب هذا الماكرو Sub SALIM_MACRO() On Error Resume Next Columns("D:D").SpecialCells(4) _ .FormulaR1C1 = "=R[-1]C" '4 =====> xlCellTypeBlanks On Error GoTo 0 End Sub
×
×
  • Create New...