ناصر سعيد

تفضل اخي العبقري ياسر العربي فلتره.rar

الاساتذه العظام اريد تفعيل الكود الرائع للاستاذ ياسر العربي او الكود المتميز للاستاذ سليم بارك الله فيهما في ملف به الرؤوس بها خلايا مدمجه

خليفه العالم العلامه غبد الله باقشير المحترم ياسر العربي يحفظك ربنا ويصونك

الف الف مبروك .. ولكن لي سؤال ارجو ان تدلوني على الاجابهخليه .. اين اكواد واعمال الاستاذ الكبير قوي يحي حسين في المنتدى ؟

شكرا للعبقري ياسر العربي خليفه العالم العلامه عبد الله باقشير

بارك الله فيك أخي الغالي عبد الله المجرب على هذا الشرح الرااائع

خطوط البسمله رائعه خطوط البسملة.rar

========================================= طباعه شهادات بطريقه مختلفه رائعه طباعة شهادات فصل.rar

استخراج رقم الجلوس بطريقه فريده رقم الجلوس2.rar

======================== كود رائع للبحث في عده صفحات للعلامه عبد الله باقشير بحث.rar

قوائم منسدله دون تكرار بالمعادلات =INDEX(Feuil1!$A:$A;MIN(IF(COUNTIF(B$2:B2;List)=0;ROW(List))))&"" قوائم منسدلة دون تكرار ودون فراغات.rar ========================================== معادله مطاطيه لاستخراج القيم الفريده =INDEX('بيانات الطلبة'!$V$7:$V$212;MATCH(0;COUNTIF($S$9:$S9;'بيانات الطلبة'!$V$7:$V$212);0)) قائمة مطاطة خاليه من ظهور علامات الخطأ.rar

استخراج القيم الفريده Const StudentData As String = "بيانات الطلبة" Const TopStudents As String = "الاوائل" Private Sub Worksheet_Activate() Application.DisplayAlerts = False Sheets(TopStudents).Range("S:S").ClearContents Sheets(StudentData).Range("V5:V1000").AdvancedFilter Action:=xlFilterCopy, copytorange:=Sheets(TopStudents).Range("S8"), unique:=True Sheets(TopStudents).Range("S9").Value = "الكل" With Sheets(TopStudents).Range("S8") .Interior.Pattern = xlSolid .Interior.Color = 65535 .Borders.LineStyle = xlContinuous .Borders.Weight = xlThin .Font.Size = 16 End With With Sheets(TopStudents).Range("S9:S100") .Interior.Pattern = xlSolid .Interior.ColorIndex = 0 .Borders.LineStyle = xlContinuous .Borders.Weight = xlThin .Font.ColorIndex = 0 .Font.Size = 16 End With Macro1 Application.DisplayAlerts = True End Sub فلترة متقدمة.zip كشوف المناداه وارقام الجلوس يصلح للثانوي العام كشوف المناداه وارقام الجلوس للثانوي العام.rar

توزيع ارقام الجلوس وكشوف المناداه بالمعادلات توزيع اللجان وارقام الجلوس بالمعادلات.rar توزيع كشوف المناداه .. وارقام الجلوس للدور التاني للمحترم الاستاذ محمد علي عبد الكريم توزيع لجان الدور التاني.rar

استخراج الشهادات بطريقه العلامه عبد الله باقشير ''هذا الكود للعالم العلامه والبحر الفهامه عبد الله باقشير حفظه الله ''استخراج شهادات الطلاب الهدف من الكود 'رقم اول صف للشهادة Const FirstRow As Integer = 7 '------------------------------- 'عدد صفوف الشهادة Const CountRow As Integer = 11 '------------------------------- 'عدد اعمدة الشهادة التي تريد اظهارها في الطباعة Const CountColumn As Integer = 13 '------------------------------- Const Range_Index As String = "A7" '------------------------------- Dim KH_Boolean As Boolean, KH_Test As Boolean Sub الكل() Call kh_Test_Fill(Sheet3.Range("D1")) If KH_Test Then GoTo 1 Sheet3.PrintPreview 1 Application.ScreenUpdating = True End Sub Sub الناجحين() Call kh_Test_Fill(Sheet3.Range("G1")) If KH_Test Then GoTo 1 Call kh_Nd("ناجح") Sheet3.PrintPreview 1 Application.ScreenUpdating = True End Sub Sub دور_ثاني() Call kh_Test_Fill(Sheet3.Range("J1")) If KH_Test Then GoTo 1 Call kh_Nd("دور ثاني") Sheet3.PrintPreview 1 Application.ScreenUpdating = True End Sub Sub kh_Test_Fill(MyCel As Range) Dim R As Integer, RR As Long KH_Boolean = True: kh_Delete: KH_Boolean = False KH_Test = False If Not IsNumeric(MyCel) _ Or (IsNumeric(MyCel) And MyCel.Value = 0) Then _ MsgBox MyCel.Offset(0, -1) & Chr(10) & Chr(10) & MyCel, 524288 + 1048576 + 16, "بيانات غير متوفرة": KH_Test = True: GoTo 1 R = MyCel.Value With Sheet3 .Range(Range_Index).Value = 1 If R = 1 Then GoTo 1 RR = (R * CountRow) Call kh_AutoFill(.Rows(FirstRow).Resize(CountRow), .Rows(FirstRow).Resize(RR), .Range("B" & FirstRow).Resize(RR, CountColumn).Address) End With 1 End Sub Sub kh_AutoFill(SourceRange As Range, fillRange As Range, Kh_PrintArea As String) SourceRange.AutoFill fillRange, xlFillDefault Sheet3.PageSetup.PrintArea = Kh_PrintArea End Sub Sub kh_Nd(Nd As String) Dim MyRng As Range Dim R As Integer, RR As Long Set MyRng = Range("data").Columns(46) RR = FirstRow With MyRng For R = 1 To .Rows.Count If .Cells(R, 1) = Nd Then Sheet3.Cells(RR, 1) = R RR = RR + CountRow End If Next End With End Sub Sub kh_Delete() Dim T As Long Application.ScreenUpdating = False With Sheet3 .Range(Range_Index).ClearContents T = .UsedRange.Rows.Count .Rows(FirstRow + CountRow).Resize(T).Delete End With If KH_Boolean Then GoTo 1 Application.ScreenUpdating = True MsgBox "تم مسح الشهادات", vbMsgBoxRight, "الحمد لله" 1 End Sub استخراج شهادات بطريقه العلامه عبد الله باقشير.rar كود لفرز البيانات بمعيار الفصل وموجود ايضا بالملف السابق اردت ان اضع الاضواء عليه Sub KH_Sort() ''هذا الكود للعالم العلامه والبحر الفهامه عبد الله باقشير حفظه الله ''فرز بيانات الطلاب بمعيار الفصل الهدف من الكود Dim MyShap As Shape Dim T As Integer Set MyShap = Sheet4.Shapes("Kh_Num") If MyShap.ControlFormat.Value = 1 Then T = 2 Else T = 1 Range("data").Sort Range("AU12"), T End Sub

كود للطباعه راائع محدد بعدد الصفحات التي تبغاها جزى الله صاحبه بكل خير Sub Print_shehada() ' ==== هذا الكود للمحترم مختار حسين محمود Dim i As Integer Application.ScreenUpdating = False Application.DisplayAlerts = False For i = Range("t4") To Range("w4") Range("t4") = i If i <= Range("w2") Then ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True End If Next i Range("t4").Select Range("t4") = 1 Range("w4") = "" Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox "بحمد الله تعالى طباعة الشهادات", vbInformation + vbMsgBoxLEFT, " مع تحيات / مختار حسين محمود " End Sub طباعة مرن مع البحث بدلالة رقم الجلوس.rar

استخراج شهادات الطلاب كل شهاده في ورقه واحده للنابغه ساجده العزاوي شهاده في ورقه واحده للنابغه ساجده.rar

سطر رااائع

استدعاء بيانات بطريقتين Sub KH_START() ''هذا الكود للعالم العلامه والبحر الفهامه عبد الله باقشير حفظه الله '' تم هذا الكود بتاريخ 10 / 7/ 2008 '' استدعاء الناجحين والدور التاني الهدف من الكود ''شرح الكود '' متغيرات Dim b As Integer, M As Integer Sheets("كشف ناجح").Range("c7:m1000").ClearContents Sheets("كشف الدور الثاني").Range("c7:m1000").ClearContents M = 7: b = 7 For R = 1 To 1000 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' If .Cells(R, z) Like "*" & "دون المستوى" & "*" Then If Sheets("رصد الترم الثانى").Cells(R, 101) Like "*" & "ناج" & "*" Then Sheets("رصد الترم الثانى").Range("A" & R).Range("b1:c1,m1,v1,ae1,an1,ay1,az1,cd1,cx1,cw1").Copy Sheets("كشف ناجح").Range("c" & M).PasteSpecial xlPasteValues Application.CutCopyMode = False M = M + 1 End If If Sheets("رصد الترم الثانى").Cells(R, 101) _ Like "*" & "دور ثان فى" & "*" Then ' If InStr(1, Sheets("رصد الترم الثانى").Cells(R, 101).Value, "دور ثان فى") Then Sheets("رصد الترم الثانى").Range("A" & R).Range("b1:c1,m1,v1,ae1,an1,ay1,az1,cd1,cx1,cw1").Copy Sheets("كشف الدور الثاني").Range("c" & b).PasteSpecial xlPasteValues Application.CutCopyMode = False b = b + 1 End If Next MsgBox ("الحمد لله تـــم ترحيل الناجحين و الراسبين إلى أوراق عمل جديدة ") Range("a1").Select Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub '------------------------------------------------ '------------------------------------------------ Sub Naageh_Raseb() 'يقوم الكود بترحيل الناجحين والراسبين في أوراق العمل المخصصة لذلك '---------------------------------------------------------------- 'تعريف المتغيرات Dim RowNageh As Long, RowRaseb As Long Dim WS As Worksheet, SHNageh As Worksheet, SHRaseb As Worksheet 'تعيين متغيرات أوراق العمل Set WS = Sheets("رصد الترم الثانى"): Set SHNageh = Sheets("كشف ناجح"): Set SHRaseb = Sheets("كشف الدور الثاني") 'مسح محتويات النطاق الذي سيتم الترحيل إليه في ورقة الناجحين SHNageh.Range("C7:M1000").ClearContents 'مسح محتويات النطاق الذي سيتم الترحيل إليه في ورقة الراسبين SHRaseb.Range("C7:M1000").ClearContents 'صف البداية الذي سيتم الترحيل إليه في ورقة الناجحين وورقة الراسبين RowNageh = 7 _ : RowRaseb = 7 'إلغاء خاصية اهتزاز الشاشة Application.ScreenUpdating = False 'حلقة تكرارية في ورقة البيانات الأساسية بداية من الصف رقم 11 حتى آخر صف For R = 7 To WS.Cells(Rows.count, 1).End(xlUp).Row 'يمثل الرقم 101 رقم العمود الذي به النتيجة في ورقة البيانات الأساسية 'إذا كانت الخلية في الصف المحدد في عمود النتيجة تساوي كلمة ناجح If InStr(1, WS.Cells(R, 101), "ناجح") Then 'نسخ النطاقات المحددة في الصف المحدد في حالة تحقق الشرط WS.Range("A" & R).Range("B1:C1,Z1,m1,v1,AE1,AN1,ay1,AZ1,cd1,cx1").Copy 'لصق البيانات المنسوخة إلى العمود الثالث في ورقة الناجحين SHNageh.Range("C" & RowNageh).PasteSpecial xlPasteValues 'إلغاء خاصية القص والنسخ Application.CutCopyMode = False 'زيادة المتغير بمقدار واحد استعداداً لبيانات جديدة RowNageh = RowNageh + 1 'إذا كانت الخلية في الصف المحدد في عمود النتيجة تساوي كلمة دور ثان في ElseIf InStr(1, WS.Cells(R, 101), "دور ثان فى") Then 'نسخ النطاقات المحددة في الصف المحدد في حالة تحقق الشرط WS.Range("A" & R).Range("B1:C1,Z1,AI1,AR1,BA1,BL1,BM1,CD1,DI1,DJ1").Copy 'لصق البيانات المنسوخة إلى العمود الثالث في ورقة الراسبين SHRaseb.Range("C" & RowRaseb).PasteSpecial xlPasteValues 'إلغاء خاصية القص والنسخ Application.CutCopyMode = False 'زيادة المتغير بمقدار واحد استعداداً لبيانات جديدة RowRaseb = RowRaseb + 1 End If 'الانتقال للصف التالي في ورقة البيانات الأساسية Next 'رسالة تفيد بانتهاء عملية الترحيل MsgBox ("الحمد لله تم ترحيل الناجحين و الراسبين إلى أوراق عمل جديدة"), vbInformation 'إعادة تفعيل خاصية اهتزاز الشاشة Application.ScreenUpdating = True End Sub استدعاء الناجحين والدور التاني1.rar

بارك الله فيك استاذنا الكريم ابوتامر ونفعنا بعلمك

هل كلمة Delet تمسح الصف بمعني تزيل الصف ام تزيل مابه فقط

اولا جزاك الله كل خير استاذ علي ولكن الكود لايمسح ولا يؤدي الغرض منه

السلام عليكم ورحمة الله وبركاته هذا كودان للاستاذ المحترم ياسر خليل وهما بخصوص نسخ صفوف بالعدد في عده صفحات وكذلك مســح صفوف بالعدد في عده صفحات عند نقلهم الى هذا الملف لايعملان .. ارجو تضبيطهم كلمة السر 1 جزاكم الله خيرا برجاء مسح الموضوع الاخر المكرر ملف الكودين.rar

للرفع رفع الله مقداركم

السلام عليكم ورحمة الله وبركاته هذا كودان للاستاذ المحترم ياسر خليل وهما بخصوص نسخ صفوف بالعدد في عده صفحات وكذلك مســح صفوف بالعدد في عده صفحات عند نتقلهم الى هذا الملف لايعملان .. ارجو تضبيطهم حتى يخف حجم الملف من المعادلات الكثيره كلمة السر 1 جزاكم الله خيرا وهذا رابط الملف الذي نريد تخفبفه http://up.top4top.net/downloadf-203bnq91-rar.html

جزاك ربي خير ا وبارك الله فيك