ناصر سعيد

Sub معاينه_طباعه() Dim SS As Integer ''من كنوز العلامة عبد الله باقشير SS = Range("عدد_الأوراق").Value * 34 Range("A1:L" & SS).RowHeight = 24 ActiveSheet.PageSetup.PrintArea = "$A$1:$L$" & SS ActiveWindow.SelectedSheets.PrintPreview [A7].Select End Sub كود معاينه مفيد.

Sub معاينه_طباعه() Dim SS As Integer ''من كنوز العلامة عبد الله باقشير SS = Range("عدد_الأوراق").Value * 34 Range("A1:L" & SS).RowHeight = 24 ActiveSheet.PageSetup.PrintArea = "$A$1:$L$" & SS ActiveWindow.SelectedSheets.PrintPreview [A7].Select End Sub كود معاينه مفيد.

Sub HH_START() Dim b As Integer, M As Integer Sheets("كشف ناجح").Range("c7:m1000").ClearContents Sheets("كشف الدور الثاني").Range("c7:m1000").ClearContents M = 7: b = 7 Application.ScreenUpdating = False For R = 1 To 1000 If InStr(1, Sheets("الشيت").Cells(R, 113).Value, "ناجح") Then Sheets("الشيت").Range("A" & R).Range("b1:c1,z1,ai1,ar1,ba1,bl1,bm1,cd1,di1,dj1").Copy Sheets("كشف ناجح").Range("c" & M).PasteSpecial xlPasteValues Application.CutCopyMode = False M = M + 1 End If If InStr(1, Sheets("الشيت").Cells(R, 113).Value, "دور ثان") Then Sheets("الشيت").Range("A" & R).Range("b1:c1,z1,ai1,ar1,ba1,bl1,bm1,cd1,di1,dj1").Copy Sheets("كشف الدور الثاني").Range("c" & b).PasteSpecial xlPasteValues Application.CutCopyMode = False b = b + 1 End If Next MsgBox ("الحمد لله تـــم ترحيل الناجحين و الراسبين إلى أوراق عمل جديدة ") Application.ScreenUpdating = True End Sub كود استدعاء رائع بتحسينات الاستاذ المحترم اسامه البراوي حفظه الله ترحيل مفيد باختبار اعمدة معينة 2.

' 'هذا الكود للمحترم ياسر العربي Sub RoundedRectangle3_Click() Dim last As Long Dim y As Long '' اول صف سيوضع فيه التذييل y = 40 Do ' ' لمنع اهتزاز الشاشه Application.ScreenUpdating = False last = Sheets("ناجح").Range("a10000").End(xlUp).Row If y - 36 >= last Then GoTo 0 ' ' اسم شيت المصدر الذي سيتم حشر الديباجخ فيه Sheets("كعب الشيت").Rows("2:7").Copy ' ' اسم شيت الديباجه التى نريد وضعها في الشيت المصدر Sheets("ناجح").Rows(y).Insert Shift:=xlDown ' 'لايقاف خاصيه القص والنسخ Application.CutCopyMode = False ' ' y = y + 36 Loop ' ' لاعاده تحديث الشاشه 0 Application.ScreenUpdating = True MsgBox "تم بحمد لله" End Sub ' ' ' ' ' ' ' ' ' ' ' ' ' ' الاستاذ الكريم ياسر العربي وضغت شرح لبعض الجمل لكودك الرائع ليكون مرجعا سهلا للاخوه ارجو ان تكمل الشرح للجمل التي لم استطع شرحها

يجزيك الله كل خير استاذ ابو عبد الباري وكل من يشارك

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

Sub RoundedRectangle3_Click() Dim last As Long Dim y As Long y = 40 Do Application.ScreenUpdating = False last = Sheets("ناجح").Range("a10000").End(xlUp).Row If y - 36 >= last Then GoTo 0 Sheets("كعب الشيت").Rows("2:7").Copy Sheets("ناجح").Rows(y).Insert Shift:=xlDown Application.CutCopyMode = False y = y + 36 Loop 0 Application.ScreenUpdating = True MsgBox "تم بحمد لله" End Sub رائع جزاك الله كل خير استاذ ياسر العربي ولكن راس الصفوف اللي المفروض هاتنطبع مغ كل صفحة ..... المطلوب ظهورها في الطباعه ممكن نسخه 2003 كرما منكم

ربنا يبارك فيك استاذ مصطفى محمود والاستاذ سليم والجمع الكريم

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

جزاكم الله خيرا .. نريد الملف يكون 2003

ارجو كما وضحت الفكره لك وضحها اكثر لنا جزاك الله خيرا

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

عشمي كبير فيكم ياملك المعادلات بن عليه حاجي في معادله في هذا الرابط جزاكم الله خيرا

للرفع لاهميه السؤال

يا ملك المعادلات بن عليه حاجي يحفظك ربنا ويصوتك وعليكم السلام ورحمة الله وبركاته

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

الاخوه الأحباب السلام عليكم ورحمة الله هذه معادله اريدها بنطاق ومش عارف اضبطها كرما منكم اريد تضبيطها جزاكم الله خيرا =IF((P3="");"";INDEX('رصد الترم الثانى'!$A$7:$FT$700;MATCH(P3;'رصد الترم الثانى'!$B$7:$B$700;0);7)) 'رصد الترم الثانى'!$A$7:$FT$700 كرما منكم عايز اعمل نطاق اسمه RangDate بدل الجزء السابق رصد الترم الثانى'!$B$7:$B$700;0) و نطاق اسمه Rang بدل الجزء السابق

الكود سليم وعند نقله في هذا الملف لايعمل

ارجو بعد اذن حضراتكم تضبيط هذا الكود ليعمل تجربه1.rar

ActiveSheet.Unprotect "123" 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:V212").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 Application.DisplayAlerts = True ActiveSheet.Protect "123" End Sub لم اوفق فيها .. جزاك الله خيرا

الاخوة الاحباب هذا كود يعمل جيدا ولكن مع اضافته في ملف به حمايه لايعمل رجاء .. اريده يعمل وكل عام وانتم بخير فلترة متقدمة.zip

رابط ذو صله

الاستاذ المحترم ابو عبد الباري ربنا يبارك لك

للرفع لاهميه السؤال

Sub kh_Filter() ''''' Dim LR As Long With Sheet2 'يمسح منطقة اخراج البيانات قبل الفلتره من بداية السطر 9 حتي نهاية ترقيم الورقة .Range(.Cells(9, 1), .Cells(Rows.Count, Columns.Count)).ClearContents End With With Sheet1 'لتحديد رقم اخر صف في قاعدة البيانات LR = .Cells(.Rows.Count, "AF").End(xlUp).Row 'كود للتصفية المتقدمة يحدد فيه مدي قاعدة البيانات ومنطقة مدي شروط التصفية وايضا مدي مخرجات ناتج التصفية .Range("AD6:BH" & LR).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheet2.Range("A1:A2"), CopyToRange:=Sheet2.Range("C9"), Unique:=True End With Range("a3").Select 'لتحديد رقم اخر صف في مدي المخرجات LR = Cells(Rows.Count, "AF").End(xlUp).Row 'يقوم بتحديد مدي منطقة طباعه المخرجات ActiveSheet.PageSetup.PrintArea = Range("b2:AB" & LR).Address End Sub وضعت شرح العملاق عمر الحسيني مع الكود كود فلتره 10.rar