سليم حاصبيا

بعض التعديلات على الملف لمعرفة قدرة الاكسيل العظيمة Ihab_salim.xlsx

ملف رائع و تعليمي من الدرجة الاولى كان لي فرصة الاطلاع فقط على الورقة 1 و كانت لي هذه الملاحظة التي ادرجتها في تكست بوكس من هذا الملف Ihab.xlsx

تم التعديل Option Explicit Sub Salim_Index() Application.ScreenUpdating = False Dim S_sh As Worksheet: Set S_sh = Sheets("الدرجات") Dim Index_sh As Worksheet: Set Index_sh = Sheets("قائمة") If ActiveSheet.Name <> Index_sh.Name Then GoTo Leave_Me_Out Dim my_st1$, my_st2$, my_st3$ Dim lr%: lr = S_sh.Cells(Rows.Count, 1).End(3).Row Dim Flt_Rg As Range: Set Flt_Rg = S_sh.Range("a4:R" & lr) Index_sh.Range("b5:c150").ClearContents my_st1 = "=" & Index_sh.[j1] my_st2 = "=" & Index_sh.[j2] my_st3 = Replace(Index_sh.[j3], "*", "") my_st3 = "*" & my_st3 & "*" Flt_Rg.AutoFilter Field:=13, Criteria1:=my_st1 Flt_Rg.AutoFilter Field:=4, Criteria1:=my_st2 Flt_Rg.AutoFilter Field:=15, Criteria1:= _ "=" & my_st3, Operator:=xlAnd '=========================== Flt_Rg.Columns(2).SpecialCells(xlCellTypeVisible).Copy Index_sh.Range("b4").PasteSpecial Paste:=xlPasteValues Flt_Rg.Columns(3).SpecialCells(xlCellTypeVisible).Copy Index_sh.Range("c4").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False Flt_Rg.AutoFilter Leave_Me_Out: Application.ScreenUpdating = True End Sub الملف filter by 3 Criterias_Modifier.xlsm

ربما كان المطلوب Salim_Saerch_By_Combo.xlsm

جرب هذا الماكرو Option Explicit Sub Salim_Index() Application.ScreenUpdating = False Dim S_sh As Worksheet: Set S_sh = Sheets("الدرجات") Dim Index_sh As Worksheet: Set Index_sh = Sheets("قائمة") If ActiveSheet.Name <> Index_sh.Name Then GoTo Leave_Me_Out Dim my_st1$, my_st2$, my_st3$ Dim lr%: lr = S_sh.Cells(Rows.Count, 1).End(3).Row Dim Flt_Rg As Range: Set Flt_Rg = S_sh.Range("a4:R" & lr) Index_sh.Range("b5:c150").ClearContents my_st1 = "=" & Index_sh.[j1] my_st2 = "=" & Index_sh.[j2] my_st3 = "=" & Index_sh.[j3] Flt_Rg.AutoFilter Field:=13, Criteria1:=my_st1 Flt_Rg.AutoFilter Field:=4, Criteria1:=my_st2 Flt_Rg.AutoFilter Field:=15, Criteria1:=my_st3 Flt_Rg.Columns(2).SpecialCells(xlCellTypeVisible).Copy Index_sh.Range("b4").PasteSpecial Paste:=xlPasteValues Flt_Rg.Columns(3).SpecialCells(xlCellTypeVisible).Copy Index_sh.Range("c4").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False Flt_Rg.AutoFilter Leave_Me_Out: Application.ScreenUpdating = True End Sub الملف مرفق filter by 3 Criterias.xlsm

لا أعلم اذا كان هذا المطلوب بالفعل صفحة salim من هذا الملف Salim_Saerch.xls

ما رأيك بهذه الثّالثة =IF(B2="","",MATCH(B2,$B$2:B2,0)-COUNTBLANK($B$2:B2)) ولكن تبقى معادلتك هي الاٌفضل لانها تعمل حتى في حالة إخفاء الصّفوف (و ليس حذفها)

معادلة رائعة اخي علي وزيادة في اثراء الموضوع احدى هاتين المعادلتين (الثانية اكثر دقّة) =IF(B2="","",MATCH(B2,$B$2:B2,0)) اذا لم يكن هناك صفوف فارغة في البيانات أو يشكل أدق =IF(B2="","",COUNTA($B$2:B2)) اذا كان هناك صفوف فارغة في البيانات

ارفع ملفاً نموذجاً (حوالي 20 اسم) مع المعلومات المطلوية بجدول وسنحاول المساعدة

الخلايا المدمجة عبء كبير على اي كود لذا ازالة الخلايا المدمجة من الملف من الضروريات يا اخي ما بالكم انتم جماعة الاكسل تعتمدون على الخلايا المدمجة في حين بمكن توسيع العامود الى اي قدر تشاؤون بالاضافة الى خاصية wrap text في الاكسل و هناك خاصية تدعى Centre Across Selection لو كنت مكان Microsoft لقمت يالغاء دمج الخلايا من الاكسل

استعمل هذه المعادلة =INDIRECT($C$7&"!E7")

ريما نال الاعجاب الكود Option Explicit Sub Salim_Index() Application.ScreenUpdating = False Dim S_sh As Worksheet: Set S_sh = Sheets("بيانات التلاميذ") Dim Index_sh As Worksheet: Set Index_sh = Sheets("فَهرَست") Dim Targ_sh As Worksheet: Set Targ_sh = Sheets("Sapace") Dim my_st1$, my_st2$ Dim lr%: lr = S_sh.Cells(Rows.Count, 1).End(3).Row Dim New_Lr% Dim Flt_Rg As Range: Set Flt_Rg = S_sh.Range("a15:k" & lr) Dim k%, m%: m = 6 Index_sh.Range("a6:F150").ClearContents Targ_sh.Cells.Clear my_st1 = "=" & UCase(Index_sh.[g5] & "*") & "" Flt_Rg.AutoFilter Field:=5, Criteria1:=my_st1 Flt_Rg.Columns(3).SpecialCells(xlCellTypeVisible).Copy Targ_sh.Range("a5").PasteSpecial Paste:=xlPasteValues Flt_Rg.Columns(5).SpecialCells(xlCellTypeVisible).Copy Targ_sh.Range("b5").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False Flt_Rg.AutoFilter New_Lr% = Targ_sh.Cells(Rows.Count, 1).End(3).Row For k = 6 To New_Lr% Step 2 Index_sh.Cells(m, 2) = Targ_sh.Cells(k, 1): Index_sh.Cells(m, 1) = k - 5 Index_sh.Cells(m, 3) = Targ_sh.Cells(k, 2) Index_sh.Cells(m, 5) = Targ_sh.Cells(k + 1, 1): Index_sh.Cells(m, 4) = k - 4 Index_sh.Cells(m, 6) = Targ_sh.Cells(k + 1, 2) m = m + 1 Next Application.ScreenUpdating = True End Sub Salim_Index.xlsm

لا اعلم اذا نانت طريقة استحراج التاريخ من الرقم القومي صحيحة لكن لنفرض ذلك الكود Option Explicit Sub Calcul() If ActiveSheet.Name <> ("salim") Then Exit Sub Dim N As Range Dim R As Double Dim lr%, t$, x$ ' ----------------------------------------------------- lr = Cells(Rows.Count, 2).End(3).Row Range("c6:c" & lr).Formula = "=0+DATE(IF(LEFT($B6,1)=""2"",MID($B6,2,2),""20""&MID($B6,2,2)),MID($B6,4,2),MID($B6,6,2))+21915" For Each N In Range("C6:C" & lr) If N <> "" Then t = "=DATEDIF(" & "c2" & "," & """" & N & """" & ",""ym"")" N.Offset(0, 1).Formula = t End If x = "=DATEDIF(" & "c2" & "," & """" & N & """" & ",""md"")" N.Offset(0, 2).Formula = x Next Range("c6:E" & lr).Value = Range("c6:E" & lr).Value End Sub الملف مرفق صفحة salim Salim_Salaire.xlsm

مع كل التقدير لعملك يمكن تحميل نموذج (غير حقيقي) او فلنسميه مزور و ذلك لمعرفة كيفية التعامل معه على كل حال اليك هذا الملف يمكن ان يكون الحل فيه serie Of number.xlsm

ارفع ملفاً بالنتائج المتوقعة كي تدرس الحالة و تجد النتيجة

الاكسل يفعلها كيفما تريد By_class Or by_ section.xlsm

ريما كان المطلوب تصحيح معادلة salim.xlsm

هذا الفيديو يوضح الأمر https://www.youtube.com/watch?v=AzOwrl-0RuE

يمكن عمل ذلك بدون كود Variable_print_Area_salim.xlsm

تم معالجة الأمر بالنسبة للملف القديم الذي رفعته (نمو ذج اخر على 3 صفحات مستقلة مع تحديد نطاق الطباعة اللازم لكل صفحة) الكود Option Explicit Sub filter_ME3() If ActiveSheet.Name <> "ورقة1" Then GoTo Exit_Me With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim S_sh As Worksheet: Set S_sh = Sheets("ورقة1") Dim T_sh As Worksheet Dim lr%, i%, new_lr%, k%, x Dim My_Table As Range: Set My_Table = _ S_sh.Range("A6").CurrentRegion Select Case S_sh.Range("b1") Case "ناجح" Set T_sh = Sheets("Salim") Case "راسب وله حق الإعادة" Set T_sh = Sheets("Salim1") Case "راسب وليس له حق الإعادة" Set T_sh = Sheets("Salim2") Case Else GoTo Exit_Me End Select ReDim arr(1 To 4) arr(1) = 1: arr(2) = 2: arr(3) = 3: arr(4) = 11 With T_sh .Select .Cells(4, 1).Resize(1000, 11).ClearContents .Cells(1, 1) = S_sh.Range("b1") .Range("Q2").Formula = "=AND(ورقة1!$K7=$A$1,ورقة1!$K8=0)" My_Table.AdvancedFilter 2, .Range("Q1:Q2"), _ .Range("A4"), 0 .Range("Q2").ClearContents .Cells(1, 1) = vbNullString '====================== lr = .Cells(Rows.Count, 1).End(3).Row If lr < 5 Then lr = 5 For i = lr To 6 Step -1 Rows(i).Insert Next new_lr% = .Cells(Rows.Count, 1).End(3).Row If new_lr% < 6 Then new_lr% = 6 For i = 6 To new_lr% + 1 Step 2 x = Application.Match(.Cells(i - 1, 1), _ S_sh.Columns(1), 0) + 1 .Cells(i, 4).Resize(, 7).Value = _ S_sh.Cells(x, 4).Resize(, 7).Value Next For i = 5 To new_lr% Step 2 For k = 1 To 4 .Cells(i, arr(k)).Resize(2, 1).MergeCells = True Next Next End With '========================== Exit_Me: Erase arr With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق دورsalim 3 sheets.xls

تم معالجة الأمر بالنسبة للملف القديم الذي رفعته الكود Option Explicit Sub filter_ME() If ActiveSheet.Name <> "Salim" Then GoTo Exit_Me With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim S_sh As Worksheet: Set S_sh = Sheets("ورقة1") Dim T_sh As Worksheet: Set T_sh = Sheets("Salim") Dim lr%, i%, new_lr%, k%, x Dim My_Table As Range: Set My_Table = _ S_sh.Range("A6").CurrentRegion ReDim arr(1 To 4) arr(1) = 1: arr(2) = 2: arr(3) = 3: arr(4) = 11 With T_sh .Range("A4").Resize(1000, 11).ClearContents .Range("Q2").Formula = "=AND(ورقة1!$K7=$A$1,ورقة1!$K8=0)" My_Table.AdvancedFilter 2, .Range("Q1:Q2"), _ .Range("A4"), 0 .Range("Q2").ClearContents End With '====================== lr = Sheets("Salim").Cells(Rows.Count, 1).End(3).Row If lr < 5 Then lr = 5 For i = lr To 6 Step -1 Rows(i).Insert Next new_lr% = Sheets("Salim").Cells(Rows.Count, 1).End(3).Row If new_lr% < 6 Then new_lr% = 6 For i = 6 To new_lr% + 1 Step 2 x = Application.Match(T_sh.Cells(i - 1, 1), _ S_sh.Columns(1), 0) + 1 T_sh.Cells(i, 4).Resize(, 7).Value = _ S_sh.Cells(x, 4).Resize(, 7).Value Next For i = 5 To new_lr% Step 2 For k = 1 To 4 T_sh.Cells(i, arr(k)).Resize(2, 1).MergeCells = True Next Next '========================== Exit_Me: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق (انظر الى الصفحة salim ) دورsalim.xls

بعد اذن اخي علي هذه المعادلة =CHOOSE((SUM($F$4:$F$5)>=10000)+1,50,SUM($F$4:$F$5)*0.05)

هذه المعادلة البسيطة في الخليةC2 وتسحب نزولاُ =$B2&"/"&$A2

كيف تعرف العمر من الرقم القومي؟؟؟

الفلتر لا يعمل كما يجب اذا كان هناك خلايا مدمجة بالجدول اذا كنت تريد يمكن استحراج النتائج بواسطة الماكرو او المعادلات