ابراهيم الحداد

السلام عليكم ورحمة الله اولا : ضع الكود التالى فى موديول مستقل و خصص له زر Sub NewTopTen() Dim ws As Worksheet, LR As Long Dim Arr(), Tmp(), n As Integer, Rnk As String Dim i As Integer, j As Integer, p As Integer Dim Num As Integer, y As Integer Const Rep As String = "مكرر" Dim WF As WorksheetFunction, C As Range Set ws = Sheets("ورقة البيانات") Set WF = WorksheetFunction LR = ws.Range("C" & Rows.Count).End(3).Row ReDim Preserve Arr(1 To LR, 1 To 1) For Each C In ws.Range("U8:U" & LR) y = WF.CountIf(ws.Range(ws.Cells(8, "U"), _ ws.Cells(C.Row, "U")), ws.Cells(C.Row, "U")) If y = 1 Then p = p + 1 Arr(p, 1) = C.Value End If Next If p < 50 Then n = p - 1 Else n = 50 End If For i = 1 To n Num = WF.Large(Arr, i) For Each C In ws.Range("U8:U" & LR) If C.Value = Num Then Rnk = TextNums(i) C.Offset(0, 1) = Rnk x = WF.CountIf(ws.Range(ws.Cells(8, "U"), _ ws.Cells(C.Row, "U")), ws.Cells(C.Row, "U")) If x > 1 Then Rnk = TextNums(i) & " " & Rep C.Offset(0, 1) = Rnk End If End If Next Next End Sub ثانيا : اما هذه الدالة المخصصة ضعها ايضا فى موديول اخر و لا تتعامل معها مرة اخرى حتى يعمل معك الكود الاول بكفاءة Function TextNums(Num As Integer) As String Dim Ar, Tp, Reslt As String Dim m As Integer Ar = Array("الاول", "الثانى", "الثالث", "الرابع", "الخامس", "السادس", "السابع", _ "الثامن", "التاسع", "العاشر", "الحادى عشر", "الثانى عشر", "الثالث عشر", _ "الرابع عشر", "الخامس عشر", "السادس عشر", "السلبع عشر", "الثامن عشر", _ "التاسع عشر", "العشرين", "الحادى و العشرين", "الثانى و العشرين", _ "الثالث و العشرين", "الرابع و العشرين", "الخامس و العشرين", "السادس و العشرين", _ "السابع و العشرين", "الثامن و العشرين", "التاسع و العشرين", "الثلاثين", "الحادى و الثلاثين", _ "الثانى و الثلاثين", "الثالث و الثلاثين", "الرابع و الثلاثين", "الخامس و الثلاثين", _ "السادس و الثلاثين", "السابع و الثلاثين", "الثامن و الثلاثين", "التاسع ة الثلاثين", _ "الاربعين", "الحادى و الاربعين", "الثانى و الاربعين", "الثالث و الاربعين", "الرابع و الاربعين", _ "الخامس و الاربعين", "السادس و الاربعين", "السابع و الاربعين", "الثامن و الاربعين", _ "التاسع و الاربعين", "الخمسين") Tp = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, _ 21, 22, 23, 24, 35, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, _ 41, 42, 43, 44, 45, 46, 47, 48, 49, 50) For m = LBound(Ar) To UBound(Ar) If Num = m + 1 Then Reslt = Replace(Num, Num, Ar(m)) End If Next TextNums = Reslt End Function

السلام عليكم و رحمة الله ترتيب الطلاب من الاول حتى العاشر على اساس الدرجات فى العمود T Sub ReRank() Dim ws As Worksheet, Arr() Dim LR As Long, y As Integer, TP() Dim j As Long, p As Long, m As Long, Trb As String Dim i As Long, x As Double, k As Double Set ws = Sheets("ورقة البيانات") LR = ws.Range("C" & Rows.Count).End(3).Row Range("U8:U" & LR).Value = "" ReDim Arr(1 To LR, 1 To 1) j = 8 Do While j <= LR y = WorksheetFunction.CountIf(ws.Range(ws.Cells(8, "T"), _ ws.Cells(j, "T")), ws.Cells(j, "T")) If y = 1 Then i = i + 1 Arr(i, 1) = ws.Cells(j, "T") End If j = j + 1 Loop x = WorksheetFunction.Large(Arr, 10) ReDim TP(1 To i, 1 To 1) For r = 1 To i If Arr(r, 1) >= x Then p = p + 1 TP(p, 1) = Arr(r, 1) End If Next m = 8 Do While m <= LR For n = 1 To 10 k = WorksheetFunction.Large(TP, n) If ws.Cells(m, "T") = k Then Trb = Choose(n, "الاول", "الثانى", "الثالث", "الرابع", "الخامس", _ "السادس", "السابع", "الثامن", "التاسع", "العاشر") If WorksheetFunction.CountIf(ws.Range("T8:T" & m), _ ws.Range("T" & m)) > 1 Then Trb = Trb & " " & "مكرر" ws.Cells(m, "U") = Trb Else Trb = Trb ws.Cells(m, "U") = Trb End If End If Next m = m + 1 Loop End Sub

السلام عليكم و رحمة الله بارك الله فيك و جعلها فى ميزان حسناتك

السلام عليكم و رحمة الله استخدم المعادلة التالية =IF($V$1="الصف الرابع";INDEX($C$5:$K$19;ROW($A1);MATCH($V$2;$C$4:$K$4;0));INDEX($L$5:$T$19;ROW($A1);MATCH($V$2;$L$4:$T$4;0)))

السلام عليكم و رحمة الله استخدم المعادلة التالية ="("&" "&INDEX($C$5:$D$9;MATCH($B$12;$D$5:$D$9;0);1)&" "&")"

السلام عليكم و رحمة الله اخى الكريم مشكلتك الوحيدة هى تحديد النطاقات المرجو العمل عليها و لذلك ستكون المعادلة الاولى هكذا =IF(B3="";"";SUMIF(ALL!$B$3:$B$1127;B3;ALL!$C$3:$C$1127)/COUNTIF(ALL!$B$3:$B$1127;B3)) و المعادلة الثانية هكذا =IF(B3="";"";SUMIF(ALL!$B$3:$B$1127;B3;ALL!$D$3:$D$1127)/COUNTIF(ALL!$B$3:$B$1127;B3)) هذا و الله اعلى و اعلم

السلام عليكم و رحمة الله ضع الكود الاول فى موديول عادى Sub HidColmns() Dim ws As Worksheet, SRng As String Dim FrRng As Range, SeRng As Range, ThRng As Range Dim LR As Long Set ws = Sheets("ورقة1") LR = ws.Range("B" & Rows.Count).End(3).Row SRng = ws.Range("C2").Text Set FrRng = ws.Range("F5:H" & LR) Set SeRng = ws.Range("I5:K" & LR) Set ThRng = ws.Range("L5:N" & LR) Application.ScreenUpdating = False Select Case SRng Case "الأول" FrRng.Columns.Hidden = False SeRng.Columns.Hidden = True: ThRng.Columns.Hidden = True Case "الثاني" SeRng.Columns.Hidden = False FrRng.Columns.Hidden = True: ThRng.Columns.Hidden = True Case "المجاميع" ThRng.Columns.Hidden = False FrRng.Columns.Hidden = True: SeRng.Columns.Hidden = True Case Else End Select Application.ScreenUpdating = True End Sub اما الكود الثانى فضعه فى حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$C$2" Then Exit Sub HidColmns End Sub

السلام عليكم و رحمة الله الاستاذ كريم و الاستاذ حسونة و الاستاذ محمد شكرا لمروركم الكريم

السلام عليكم و رحمة الله اخوتى و احبائى شرفنى مروركم الكريم و مشاعركم الطيبة

السلام عليكم و رحمة الله اخوتى و أحبتى اعضاء منتدى اوفيسنا الحقيقة ترددت كثيرا قبل كتابة هذا الموضوع و لعدة اسابيع و لكنى اليوم قررت ان ارتدى ثوب الشجاعة و اقدم اليكم ذلك البرنامج المتواضع و الذى كلفنى جهدا ليس بالقليل و قد اوحى الى فكرته حفيدى مازن لذا قررت ان اسمى البرنامج باسمه و فكرة البرنامج هو استعراض حروف و كلمات اللغة العربية البسيطة و التى تناسب عقلية تلميذ كى جى 1 و كى جى 2 مدعوما بالصور التى قد يعرفها الطفل فى ذلك العمر ملحوظة هامة : لابد من دعم الابوين حتى يتعلم الطفل استخدام البرنامج بنفسه و الآن على بركة الله .... اليكم البرنامج ( بعد فك الضغط لا يتم استخراج اى ملف من الفولدر) Mazen.rar

السلام عليكم و رحمة الله المفترض ان المعادلة تكون هكذا =IF(B3="";"";SUMIF(ALL!$B$3:$B$1127;B3;ALL!$E$3:$E$1127)/COUNTIF(ALL!$B$3:$B$1127;B3)) ضع المعادلة فى الخلية E3 ثم اسحب نزولا حتى آخر خلية

السلام عليكم و رحمة الله غير لرقام بالمعادلة التى هى 1033 الى 1127 و تحل المشكلة ان شاء الله

السلام عليكم و رحمة الله عذرا اخى الكريم فاتنى ان انبهك ان تكون اسماء الشهور فى فى ورقة الخلاصة مطابقة لاسماء الشهور فى القائمة المتسدلة فى ورقة الكشف و لكى يكون عملك دقيقا قم بنسخ اسم الشهر من القائمة المنسدلة الى صف الشهور و كرر هذا مع كل الشهور لكى تضمن مطابقة الكلمتين تماما و ساعتها سيعمل معك الكود بكل سرعة و سلاسة هذا و الله ولى التوفيق

السلام عليكم و رحمة الله استخدم الكود التالى Sub TrAbsent() Dim ws As Worksheet, Sh As Worksheet Dim Shahr As String, x As Long, Rng As Range Set ws = Sheets("خلاصة نهائية"): Set Sh = Sheets("كشف") Shahr = Sh.Range("AD3").Text x = WorksheetFunction.Match(Shahr, ws.Range("D5:CY5"), 0) + 3 Sh.Range("AJ8:AR73").Copy ws.Cells(8, x).PasteSpecial xlPasteValues Application.CutCopyMode = False End Sub

السلام عليكم و رحمة الله استخدم المعادلة التالية =INDEX($B$2:$K$8;MATCH($B$15;$A$2:$A$8;0);MATCH($C$15;$B$1:$K$1;0))

السلام عليكم و رحمة الله قم بتعديل sore1 الى Store 1 فى العمود B فى شيت data

السلام عليكم و رحمة الله استخدم تلك المعادلة فى العمودين A و B =IFERROR(INDEX(data!$B$2:$D$9;SMALL(IF(data!$B$2:$B$9=$B$1;ROW(data!$B$2:$B$9));ROW(B1));COLUMN()+1);"") ثم اضغط CTRL+ SHFT + ENTER فى كل مرة حتى تعمل معك المعادلة بكفاءة

السلام عليكم ورحمة الله اخولنى الكرام الكود التالى لنقل بيانات الغائبين من شيت data الى شيت غياب لجان غدا سأحاول تكملة الموضوع ان كان فى العمر بقية Sub AlAbst() Dim Data As Worksheet, ws As Worksheet Dim LR As Long, x As Integer Dim Arr As Variant, Tmp As Variant Dim Mad As String, Cls As String Dim i As Long, j As Long, p As Long Set Data = Sheets("data") LR = Data.Range("B" & Rows.Count).End(3).Row Set ws = Sheets("غياب لجان") ws.Range("A11:D100") = "" Mad = ws.Range("D8").Text x = WorksheetFunction.Match(Mad, Data.Range("A6:M6"), 0) - 1 Arr = Data.Range("B7:M" & LR).Value ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, x) = "غ" Then p = p + 1 For j = 1 To 4 Tmp(p, j) = Arr(i, Choose(j, 4, 2, 1, 3)) Next End If Next If p > 0 Then ws.Range("A11").Resize(p, UBound(Tmp, 2)).Value = Tmp End Sub

السلام عليكم و رحمة الله ضع المعادلة التالية فى عمود الاسماء =IFERROR(INDEX(ورقة1!$B$2:$C$12;SMALL(IF((ورقة1!$C$2:$C$12>=$F$1)*(ورقة1!$C$2:$C$12<=$E$1)>0;ROW(ورقة1!$C$2:$C$12));ROW(A1))-1;1);"") ثم اضغط CTRL+ SHIFT + ENTER و اسحب نزولا حتى آخر خلية كرر نفس المعادلة فى عمود التاريخ و غير الرقم الاخير فى المعادلة و هو 1 الى 2

السلام عليكم و رحمة الله اعتقد ان الربط بين الكودين صعب نوعا ما الكود المدرج بمشاركتك الاخيرة هو هايبرلنك و يختلف عن الكود المدرج بمشاركتى السابقة و الله اعلى و اعلم

السلام عليكم و رحمة الله ضع الكود التالى فى موديول ثم اربط الكود بكل زر يحمل اسم ورقة معينة بشرط ان يتفق اسم الورقة مع الاسم المكتوب على الزر تماما Sub OpenSheet() Dim x As String On Error Resume Next x = ActiveSheet.Buttons(Application.Caller).Caption Sheets(x).Visible = xlSheetVisible Sheets(x).Select End Sub

السلام عليكم ورحمة الله يمكنك استخدام الكود التالى Sub JnQuran() Dim ws As Worksheet, LR As Long Dim Arr(), Tmp, Tgrt As String, Reslt As String Dim i As Long, j As Long, p As Long Set ws = Sheets("حفص") LR = ws.Range("E" & Rows.Count).End(3).Row Tgrt = ws.Range("L17") Arr = ws.Range("C2:E" & LR).Value ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 1)) For i = 1 To UBound(Arr, 1) If Arr(i, 3) = Tgrt Then p = p + 1 Tmp(p, 1) = Arr(i, 2) & Arr(i, 1) Reslt = Reslt & "" & Tmp(p, 1) End If Next ws.Range("I3") = Reslt End Sub

السلام عليكم و رحمة الله استخدم هذا الكود Private Sub CommandButton1_Click() Dim ws As Worksheet, x As Integer Dim L1 As Long, L2 As Long Set ws = Sheets("Sheet1") L1 = ws.Range("A" & Rows.Count).End(3).Row L2 = ws.Range("B" & Rows.Count).End(3).Row x = L1 - L2 If x = 0 Then Exit Sub ws.Range("B" & L2 + 1).Resize(x) = Me.TextBox1.Value End Sub

السلام عليكم و رحمة الله بارك الله فيك دائم الابداع

السلام عليكم و رحمة الله اليك الكود هو بطئ نسبيا نظرا لطول البيانات و تعدد الخيارات جارى العمل على ايجاد كود اسرع و لكن فى وقت لاحق ان شاء الله Sub Filtrng() Dim Rng As Range, Dta As String Dim i As Long, LR As Long Application.ScreenUpdating = False LR = Range("A" & Rows.Count).End(3).Row i = 2 Do While i <= LR Dta = Left(Cells(i, 1), 3) If Dta = "080" Or Dta = "081" Or Dta = "082" Then Range("A" & i).EntireRow.Hidden = False Else Range("A" & i).EntireRow.Hidden = True End If i = i + 1 Loop Application.ScreenUpdating = True End Sub