abuhanen10

اخوانى الاعزاء كود بحث بمعيار واحد داخل كل الشيت وليس صفحه واحه اريد التعديل ليكون بمعيارين او ثلاثه اولا الكود Function VLookupInRanges(v As Variant, c As Long, ParamArray rng() As Variant) As Variant Dim r As Variant Dim i As Long r = CVErr(xlErrRef) For i = LBound(rng) To UBound(rng) r = Application.VLookup(v, rng(i), c, False) If Not IsError(r) Then Exit For End If Next i VLookupInRanges = r End Function ثانيا معادله البحث =VLookupInRanges($L$4,10,'1'!$C$11:$W$150,'2'!$C$11:$W$150,'3'!$C$11:$W$150,5) ثالثا ملف التطبيق البحث بشروط.rar

شكرا جزيلا

معلش ممكن تفاصيل انا اوفيس 2010 عربى

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

اخوانى ممكن تلوين خلاليا حسب الشروط الموضحه فى المرفق تلوين بشرط.rar

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

الاخوه الاعزاء ممكن تغيير هذه المعادله بكود =IF(F10=ناجح,"1",IF(F10=راسب,"2",IF(F10="","")))

الف الف شكر

اتفضل يا باشا ابجده.rar

اخوانى الاعزاء اعضاء اوفيسنا الكرام ارجوا من احد العباقره الكرام وما أكثرهم كود ابجده حسب العمر من الكبير للصغير ومن الصغير للكبير شكرا مقدما وإلى الأمام دائما

اخوانى الاعزاء اعضاء اوفيسنا الكرام ارجوا من احد العباقره الكرام وما أكثرهم كود ابجده حسب العمر من الكبير للصغير ومن الصغير للكبير شكرا مقدما وإلى الأمام دائما

استاذ ياسر اذا ممكن شرح هذا الكود فقط Sub الأكبر() If Range("A1").Value = 0 Then MsgBox "لا توجد أسماء مُسجلة", , : Exit Sub If Range("C1").Value = 0 Then MsgBox "لا توجد أرقام قومية مُسجلة", , : Exit Sub Application.ScreenUpdating = False sheet1.Range("B3:D2002").copy Sheet2.Visible = True Sheet2.Select Sheet2.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("R3:R2002").copy Sheet2.Select Sheet2.Range("E3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Dim cel As Range, rng As Range Dim rngSort As Range Set rng = Sheet2.Range("B3", Sheet2.Range("B2002").End(xlUp)) For Each cel In rng If cel.Value = "" Then cel.EntireRow.Hidden = True End If Next cel Sheet2.Range("B3:E2003").Select Sheet2.Range("E3").Activate ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear ActiveWorkbook.ActiveSheet.Sort.SortFields.add Key:=Range("E1673"), _ SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal With ActiveWorkbook.ActiveSheet.Sort .SetRange Range("B3:E2003") .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Rows("3:2002").EntireRow.Hidden = False Sheet3.Visible = True Sheet3.Range("B3:D2002").copy sheet1.Visible = True sheet1.Select sheet1.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("B3").Select Call CleanB Sheet2.Visible = False Sheet3.Visible = False sheet1.Range("E1").Value = "الأكبر أولاً" Application.ScreenUpdating = True End Sub

اخوانى الاعزاء عباقره اوفسينا هذا كود رائع للابجده بأنواعها حبيت اضيفه للشيت عندى يعطى كثير من الخطأ هل يمكن تطويعه ليعمل على اى شيت مع شرح الاسطر التى يجب تغييرها طبعا لن ارفع الكود فى ملف لانى اريد ان اضيفه بنفسى فى اكثر من شيت ولكم جزيل الشكر Sub ذكور_أولاً() If Range("A1").Value = 0 Then MsgBox "لا توجد أسماء مُسجلة", , : Exit Sub If Range("J1").Value = "no" Then MsgBox "سجل النوع لكل الطلاب أولاً", , : Exit Sub If Range("L2").Value = 0 Then MsgBox "لا يوجد ذكور مُسجلون", , : Exit Sub Application.ScreenUpdating = False sheet1.Range("B3:D2002").copy Sheet2.Visible = True Sheet2.Select Sheet2.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("R3:R2002").copy Sheet2.Select Sheet2.Range("E3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Dim cel As Range, rng As Range Dim rngSort As Range Set rng = Sheet2.Range("B3", Sheet2.Range("B2002").End(xlUp)) For Each cel In rng If cel.Value = "" Then cel.EntireRow.Hidden = True End If Next cel Set rngSort = Sheet2.Range("B3", Sheet2.Range("B3").SpecialCells(xlCellTypeLastCell)) rngSort.Select Selection.Sort Key1:=Sheet2.Range("B3"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Selection.Sort Key1:=Range("D3"), Order1:=xlDescending, Header:= _ xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Rows("3:2002").EntireRow.Hidden = False Sheet3.Visible = True Sheet3.Range("B3:D2002").copy sheet1.Visible = True sheet1.Select sheet1.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("B3").Select Call CleanB Sheet2.Visible = False Sheet3.Visible = False sheet1.Range("E1").Value = "الذكور أولاً" Application.ScreenUpdating = True End Sub Sub إناث_أولاً() If Range("A1").Value = 0 Then MsgBox "لا توجد أسماء مُسجلة", , : Exit Sub If Range("J1").Value = "no" Then MsgBox "سجل النوع لكل الطلاب أولاً", , : Exit Sub If Range("M2").Value = 0 Then MsgBox "لا توجد إناث مُسجلات", , : Exit Sub Application.ScreenUpdating = False sheet1.Range("B3:D2002").copy Sheet2.Visible = True Sheet2.Select Sheet2.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("R3:R2002").copy Sheet2.Select Sheet2.Range("E3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Dim cel As Range, rng As Range Dim rngSort As Range Set rng = Sheet2.Range("B3", Sheet2.Range("B2002").End(xlUp)) For Each cel In rng If cel.Value = "" Then cel.EntireRow.Hidden = True End If Next cel Set rngSort = Sheet2.Range("B3", Sheet2.Range("B3").SpecialCells(xlCellTypeLastCell)) rngSort.Select Selection.Sort Key1:=Sheet2.Range("B3"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Selection.Sort Key1:=Range("D3"), Order1:=xlAscending, Header:= _ xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Rows("3:2002").EntireRow.Hidden = False Sheet3.Visible = True Sheet3.Range("B3:D2002").copy sheet1.Visible = True sheet1.Select sheet1.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("B3").Select Call CleanB Sheet2.Visible = False Sheet3.Visible = False sheet1.Range("E1").Value = "الإناث أولاً" Application.ScreenUpdating = True End Sub Sub أبجدة_عامة() If Range("A1").Value = 0 Then MsgBox "لا توجد أسماء مُسجلة", , : Exit Sub Application.ScreenUpdating = False sheet1.Range("B3:D2002").copy Sheet2.Visible = True Sheet2.Select Sheet2.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("R3:R2002").copy Sheet2.Select Sheet2.Range("E3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Dim cel As Range, rng As Range Dim rngSort As Range Set rng = Sheet2.Range("B3", Sheet2.Range("B2002").End(xlUp)) For Each cel In rng If cel.Value = "" Then cel.EntireRow.Hidden = True End If Next cel Set rngSort = Sheet2.Range("B3", Sheet2.Range("B3").SpecialCells(xlCellTypeLastCell)) rngSort.Select Selection.Sort Key1:=Sheet2.Range("B3"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Rows("3:2002").EntireRow.Hidden = False Sheet3.Visible = True Sheet3.Range("B3:D2002").copy sheet1.Visible = True sheet1.Select sheet1.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("B3").Select Call CleanB Sheet2.Visible = False Sheet3.Visible = False sheet1.Range("E1").Value = "أبجدة عامة" Application.ScreenUpdating = True End Sub Sub الأكبر() If Range("A1").Value = 0 Then MsgBox "لا توجد أسماء مُسجلة", , : Exit Sub If Range("C1").Value = 0 Then MsgBox "لا توجد أرقام قومية مُسجلة", , : Exit Sub Application.ScreenUpdating = False sheet1.Range("B3:D2002").copy Sheet2.Visible = True Sheet2.Select Sheet2.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("R3:R2002").copy Sheet2.Select Sheet2.Range("E3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Dim cel As Range, rng As Range Dim rngSort As Range Set rng = Sheet2.Range("B3", Sheet2.Range("B2002").End(xlUp)) For Each cel In rng If cel.Value = "" Then cel.EntireRow.Hidden = True End If Next cel Sheet2.Range("B3:E2003").Select Sheet2.Range("E3").Activate ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear ActiveWorkbook.ActiveSheet.Sort.SortFields.add Key:=Range("E1673"), _ SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal With ActiveWorkbook.ActiveSheet.Sort .SetRange Range("B3:E2003") .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Rows("3:2002").EntireRow.Hidden = False Sheet3.Visible = True Sheet3.Range("B3:D2002").copy sheet1.Visible = True sheet1.Select sheet1.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("B3").Select Call CleanB Sheet2.Visible = False Sheet3.Visible = False sheet1.Range("E1").Value = "الأكبر أولاً" Application.ScreenUpdating = True End Sub Sub الأصغر() If Range("A1").Value = 0 Then MsgBox "لا توجد أسماء مُسجلة", , : Exit Sub If Range("C1").Value = 0 Then MsgBox "لا توجد أرقام قومية مُسجلة", , : Exit Sub Application.ScreenUpdating = False sheet1.Range("B3:D2002").copy Sheet2.Visible = True Sheet2.Select Sheet2.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("R3:R2002").copy Sheet2.Select Sheet2.Range("E3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Dim cel As Range, rng As Range Dim rngSort As Range Set rng = Sheet2.Range("B3", Sheet2.Range("B2002").End(xlUp)) For Each cel In rng If cel.Value = "" Then cel.EntireRow.Hidden = True End If Next cel Sheet2.Range("B3:E2003").Select Sheet2.Range("E3").Activate ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear ActiveWorkbook.ActiveSheet.Sort.SortFields.add Key:=Range("E1673"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.ActiveSheet.Sort .SetRange Range("B3:E2003") .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Rows("3:2002").EntireRow.Hidden = False Sheet3.Visible = True Sheet3.Range("B3:D2002").copy sheet1.Visible = True sheet1.Select sheet1.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("B3").Select Call CleanB Sheet2.Visible = False Sheet3.Visible = False sheet1.Range("E1").Value = "الأصغر أولاً" Application.ScreenUpdating = True End Sub

الف الف شكر لكم جميعا اساتذتى الكرام واسف جداااا لتأخرى فى الرد اكثر من حل جعلكم الله دائما عونا لكل محتاج للعلم

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

ممكن مساعده لإلغاء الخطأ حاولت كثيرا بلا فائده

بعد تعديل الكود والثانيه بعد التنفيذ

هنا لا يقبل التعديل صوره من ملف Help

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

نزلت من الموقع اكثر من فور والغالبيه العظمى لاتفتح عندى عندى ويندوز 10 _64 بت واوفيس 2010 وهذه صوره المشكله

رسائل خطأ عند فتح الملفات