ناصر سعيد

لماذا تكرر موضوعك ... الم ينصحك الناصحون بعدم تكرار المواضيع ؟

شوفوا نفس الموضوع مع نفس المشكله من 6 اشهر... الله يصلح حالي وحالك

فين اسم المستخدم ... فين الرقم السري ... ايه الحكايه ؟ ================= استحلفكم بالله ان نجعل العمل خالصا لوجه الله الكريم وذلك باننا نجعل اسم المستخدم والرقم السري دائما في جميع اعمال الاخوه الكرام الرقم 1 ... (1) واحد فقط بالحساب للسهوله وهذا هو القدوة الذي نقتدي بها العلامه عبد الله باقشير يترك اعماله مفتوحة او السري 1 وكذلك يفعل العمالقه

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

جزاك الله كل خير

جزاك الله كل خير وبارك فيك عالمنا الكبير عبد الله باقشير

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

ربنا يبارك فيكم استاذ سليم واستاذ خالد

للرفع للاستفاده من العمل الرائع

========== قوائم الفصــول.rar =*=*=*=*=*=*=*=*= هذا الكود من الروائع التي يجب الاهتمام بها

'https://www.officena.net/ib/topic/71642-* '========================================= Sub Classes_Lists() 'Author : YasserKhalil 'Release : 07 - 09 - 2016 '------------------------ Dim shSource As Worksheet Dim shTarget As Worksheet Dim rList As Range Dim rListA As Range Dim rListB As Range Dim strCrit As Range Dim colNum As Integer Dim Lr As Long Dim hCount As Long Dim tCount As Long '=========================================================== 'رقم أول صف للبيانات وهو صف العناوين Const firstRow As Integer = 1 '[A] رقم أول عمود للبيانات ، الرقم 1 يمثل العمود الأول Const colFirst As Integer = 1 '[D] رقم آخر عمود للبيانات ، الرقم 4 يمثل العمود الرابع Const colLast As Integer = 4 '[A:D] رقم الحقل المراد فلترته داخل النطاق ، فالرقم 4 يمثل الحقل الرابع في النطاق Const iCol As Integer = 4 'الورقة المصدر التي تحتوي على البيانات Set shSource = Sheets("ورقة1") 'الورقة الهدف التي ستوضع فيها النتائج Set shTarget = Sheets("ورقة2") 'عنوان أول خلية ستوضع فيها النتائج في الورقة الهدف Set rListA = shTarget.Range("A2") 'الخلية التي تحتوي على شرط الفلترة للبيانات Set strCrit = shTarget.Range("J1") '=========================================================== If IsEmpty(strCrit) Then MsgBox "The Criteria Cell Is Empty", vbExclamation: Exit Sub colNum = (colLast - colFirst) + 1 Set rListB = rListA.Offset(, colNum) SpeedUp shSource.Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = "Temp" Set shSource = Sheets("Temp") With shSource shTarget.Range(shTarget.Columns(colFirst), shTarget.Columns(colLast)).Resize(, colNum * 2).Clear .Range(.Cells(firstRow, colFirst), .Cells(firstRow, colLast)).Copy rListA.Offset(-1) .Range(.Cells(firstRow, colFirst), .Cells(firstRow, colLast)).Copy rListA.Offset(-1, colNum) .Range(.Cells(firstRow, colFirst), .Cells(firstRow, colLast)).AutoFilter Field:=iCol, Criteria1:=strCrit .Range(.Columns(colFirst), .Columns(colLast)).Copy .Cells(firstRow, colLast + 5) .AutoFilterMode = False Lr = .Cells(Rows.Count, colLast + 5).End(xlUp).Row .Range(.Cells(firstRow + 1, colLast + 5), .Cells(Lr, colLast + 5)).Formula = "=ROW()-" & firstRow & "" Set rList = .Range(.Cells(firstRow + 1, colLast + 5), .Cells(Lr, colLast + 5)) tCount = rList.Cells.Count hCount = Application.RoundUp(tCount / 2, 0) rListA.Resize(Rows.Count - (rListA.Row), (colNum * 2)).ClearContents rListA.Resize(hCount, colNum).Value = Range(rList(1).Address(External:=True) & ":" & rList(hCount).Address(External:=True)).Resize(hCount, colNum).Value rListB.Resize(tCount - hCount, colNum).Value = Range(rList(hCount + 1).Address(External:=True) & ":" & rList(tCount).Address(External:=True)).Resize(hCount, colNum).Value .Delete End With With rListA.Offset(-1).CurrentRegion .ReadingOrder = xlRTL .Font.Name = "Arial" .Font.Size = 11 .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter .RowHeight = 19 .Borders.Value = 1 End With With rListA.Offset(-1).Resize(, colNum * 2) .Font.Size = 14: .Interior.Color = vbCyan: .RowHeight = 25 End With Application.Goto strCrit SpeedDown End Sub Function SpeedUp() With Application .DisplayAlerts = False .Calculation = xlManual .ScreenUpdating = False .DisplayStatusBar = False .EnableEvents = False End With End Function Function SpeedDown() With Application .CutCopyMode = False .DisplayAlerts = True .Calculation = xlAutomatic .ScreenUpdating = True .DisplayStatusBar = True .EnableEvents = True End With End Function '************************************************************** 'يوضع الكود التالي في حدث ورقة العمل التي ستظهر فيها النتائج 'وهي ورقة العمل المخصصة لتجهيز قوائم الفصول '------------------------------------------------------------ Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$J$1" Then Call Classes_Lists End If End Sub جزاك الله كل خير استاذ ياسر خليل الكود يعمل جيدا على اكسبل 2010 ولكن نريد ترك عده صفوف راس وتحتها 3 صفوف لتاخذ بعض المعلومات مثل شؤن طلاب ... رئيس شئون طلاب ... مدير المدرسه لو تم تفعيله على هذا الملف سيكون سريعا جدا ورائعا كتبه الله في كفة حسناتك استاذ ياسر ========== سأرفق ملفا ان شاء الله

تكوين فصول روعه

============================= Sub KH_START() 'هذا الكود خاص بالعالم العلامه عبد الله باقشير 'الهدف من الكود هو توزيع الطلاب على قوائم 'تم هذا العمل في 2/8/2006 '=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* Dim MyRange As Range Dim R As Integer, C As Integer, M As Integer, Y As Integer, t As Integer Set MyRange = Range("School") Application.Calculation = xlCalculationManual Application.ScreenUpdating = False '================================= ' مسح البيانات KH_ClearContents '================================= ' فرز School KH_Sort '================================= If IsEmpty(Range("E2")) Or IsNumeric(Range("E2")) = False Then t = 40 Else t = Range("E2").Value C = 10 With MyRange For R = 1 To .Rows.Count If .Cells(R, 2) <> "" Then If .Cells(R, 13).Text = Range("E5").Text And .Cells(R, 14).Text = Range("F5").Text Then If Range("D5").Text = "" Then GoTo 1 If .Cells(R, 3).Text = Range("D5").Text Then 1 If M >= t Then Y = 6: M = 0 M = M + 1 If Y = 6 Then Cells(C + M, Y + 2) = M + t Else Cells(C + M, Y + 2) = M Cells(C + M, Y + 3) = .Cells(R, 2) Cells(C + M, Y + 4) = .Cells(R, 8) Cells(C + M, Y + 5) = .Cells(R, 4) Cells(C + M, Y + 6) = .Cells(R, 10) End If End If End If Next R End With '================================= 'اخفاء الصفوف المتبقية من التعيين If t = 40 Then GoTo 2 With Range("B11:L50") .Offset(t, 0).Resize(40 - t).EntireRow.Hidden = True End With '================================= Application.Calculation = xlCalculationAutomatic 2 Application.ScreenUpdating = True End Sub Sub KH_ClearContents() With Range("B11:L50") .ClearContents .EntireRow.Hidden = False End With End Sub Sub KH_Sort() With Range("School") .Sort .Columns("B:B"), xlAscending .Sort .Columns("C:C"), xlDescending End With End Sub ربنا يجزيك خيرا ايها العالم الجليل عبد الله باقشير ======= 'هذا الكود خاص بالعالم العلامه عبد الله باقشير '=*==*==*==*==*==*==*==* Option Explicit Dim OldColor Dim جدول_التجميع() Dim Col As Integer Private Sub Check_Text_Click() نص_البحث_Change End Sub Private Sub UserForm_Activate() If ActiveSheet.CodeName = "ورقة7" Then With قائمة_البحث .Visible = True .AddItem " الاسم / " .AddItem " رقم الجلوس / " .Text = .List(0) End With Else نص_البحث.Width = 145.75 End If End Sub Private Sub زر_الخروج_Click() If فورم_البحث.Height = 50 Then ActiveCell.Resize(1, 1 + Col).Interior.ColorIndex = OldColor End End Sub Private Sub زر_الفتح_Click() ActiveCell.Resize(1, 1 + Col).Interior.ColorIndex = OldColor فورم_البحث.Height = 300 زر_الفتح.Visible = False End Sub Private Sub قائمة_البحث_Change() If قائمة_البحث.ListIndex = 0 Then Col = 5 Else Col = 2 نص_البحث.Text = "" End Sub Private Sub لست_البحث_Click() Dim cc As String cc = جدول_التجميع(لست_البحث.ListIndex) Range(cc).Resize(1, 1 + Col).Activate OldColor = Range(cc).Interior.ColorIndex Range(cc).Resize(1, 1 + Col).Interior.ColorIndex = 6 فورم_البحث.Height = 50 زر_الفتح.Visible = True End Sub Private Sub زر_البحث_Click() On Error GoTo 0 1 End Sub Private Sub نص_البحث_Change() On Error Resume Next Dim MyWorksheet As Worksheet Dim R As Integer, C As Integer, v As Integer Dim M As String, MyTextFind As String Dim MyCell As Range, A As Range Set MyWorksheet = ActiveSheet لست_البحث.Clear If نص_البحث.Text = "" Then GoTo 1 '==================== If ActiveSheet.CodeName = "ورقة7" And Check_Text.Value = True Then _ M = قائمة_البحث.Text & نص_البحث.Text _ Else M = نص_البحث.Text '======================================== If Check_Text.Value = True Then MyTextFind = M & "*" _ Else: MyTextFind = "*" & M & "*" '======================================== With MyWorksheet R = .UsedRange.Rows.Count C = .UsedRange.Columns.Count Set MyCell = Range(.Cells(1, 1), .Cells(R, C)) For Each A In MyCell If ActiveSheet.CodeName = "ورقة7" And Check_Text.Value = False Then If A.Value Like MyTextFind And Left(A.Value, Len(قائمة_البحث.Text)) = قائمة_البحث.Text Then لست_البحث.AddItem A.Value ReDim Preserve جدول_التجميع(v) جدول_التجميع(v) = A.Address v = v + 1 End If Else If A.Value Like MyTextFind Then لست_البحث.AddItem A.Value ReDim Preserve جدول_التجميع(v) جدول_التجميع(v) = A.Address v = v + 1 End If End If Next End With On Error GoTo 0 1 End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode <> 1 And فورم_البحث.Height = 50 Then ActiveCell.Resize(1, 1 + Col).Interior.ColorIndex = OldColor ' Cancel = 1 End If End Sub ربنا يجزيك خيرا ايها العالم الجليل عبد الله باقشير

تكوين قوائم فصول المدرسة هذا الملف من ابداع العلامة عبد الله باقشير .. وهو خاص بتكوين قوائم للفصول المدرسيه .. ولاأروع منه جزاه الله عنا كل خير وبارك له =*=*=*=*=*=*= طريقه العمل مع الملف * املأ الجدول الموجود بالخلايا V6 :W20 بصفحة بيانات اساسيه بما يتناسب مع بيانات مدرستك * املأ بيانات طلاب مدرستك بفصولها كامله ( جميع الصفوف الدراسيه ) في الجدول الموجود بالخلايا C6: O.. * انتقل الى صفحة تكوين فصل واكتب في الخليه E5 رقم الصف الذي تريد قائمة فصل من فصوله وفي الخليه F5 اكتب رقم الفصل * اضغط الزر KH_START اذا اردت جوده المظهر في القائمه .. فحمل الخطوط الموجوده ادناه ... في جهازك اولا =*=*=*=*=*= ادعو الله ان يكون هذا العمل متقبلا من الله تكوــــــــــــــــــــــــين فصول.rar ==================== خط.rar ========== رابط لخطوط غايه في الجمال والروعه https://up.top4top.net/downloadf-3206k2ma1-rar.html

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

الاخ فايز انت كررت نفس موضوعك عده مرات مما بشتت الجميع ... عندما تريد ان ترفع الموضوع مره اخرى اكتب في نفس الموضوع .... للرفع الشكر واصل للاستاذ المحترم بن عليه ... كتب للرفع حتى ترى الحل جزاه الله كل خير

Sub Print_FROM_TO() 'هذا الكود خاص بالمحترم بن عليه حاجي 'وهو من اهلنا بالجزائر حفظهم الله ورعاهم 'الهدف من الكود طباعه صفحات 'كل صفحه تحتوي على 9 'تحديد الطباعه من ... الى والخطوة 9 For I = [T2] To [U2] Step 9 If I >= [V5] And I <= [V6] Then [B6] = I ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True End If Next [B6] = [V5] End Sub حفظك الله ورعاك الاستاذ المحترم بن عليه حاجي جزاك الله خيرا

اخي المحترم بن عليه جزاك الله كل خير ... وبعد مجرد سؤال : هل جربت الكود على طابعه او طابعه وهميه ؟ اختيار قيم من ... إلى ... فيه خطأ : اختيار قيمتي من... و إلى ... من قيم المجال [V5 ، V6] مستوى حماية الماكرو منخفضه (مما يعني أن الماكرو مفعل ). =============== اختيار قيم من ... إلى ... ليس فيه خطأ : اختيار قيمتي من... و إلى ... من قيم المجال [V5 ، V6]

اخي المحترم بن عليه جزاك الله كل خير ... وبعد بعد الضغط على زر الطباعه لايحدث الطباعه ولا ادري ما السبب

المحترم بن عليه تم نقل الموضوع الى هذا الرابط الموجود ادناه

هذا ملف به ارقام جلوس الطلاب ... كل صفحه بها 9 ارقام جلوس اريد تفعيل هذا الكود الخاص بالمحترم بن عليه .. جزاه الله عنا كل خير وجزاكم الله كل خير Sub Print_FROM_TO() For I = [P2] To [Q2] Step 4 If I >= [U1] And I <= [U2] Then [I9] = I ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True End If Next [I9] = [U1] End Sub طباعــــــة بن عليه.rar

ان شاء الله سنغير معادلات البحث في الشهاده ولكن اريد الكود يعتمد على رقم خليه رقم الجلوس بدلا من الخليه N جزاك الله خيرا

اخي الكريم بن عليه هل يمكن الاعتماد على خليه رقم الجلوس بدل الخليه N ام لابد من الاعتماد على الخليه N ================= جزاك الله خيرا

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

كود طباعه رااائع .. جزاك الله كل خير استاذ بن عليه Sub Print_All() 'هذا الكود للمحترم الفذ بن عليه حاجي 'الهدف من الكود هو طباعه كل الشهادات 'ستكون الصفحه بها 4 شهادات 'تم هذا الكود في 10 /6 /2017 '=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*==*=*=* 'اسم خليه نهاية الطباعه( إلى ) '(Step 4)كل 4 شهادات في صفحه For I = 1 To [O1] Step 4 'اسم خليه بدايه الطباعه( من ) [N1] = I ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True Next [N1] = 1 End Sub ========================= ماهو التغيير اللازم في الكود ليصبح الطباعه من - الى ؟ جزاكم الله خيرا