الـعيدروس

السلام عليكم بعد اذن الاخ الفاضل حمادة باشا هذا كود الاخ حمادة باشا بتعديل بسيط الصق الكود في حدث Thisworkbook Private Sub Workbook_Open() layout_changed = False End Sub Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) If Intersect(Target, Range("B5:B32")) Is Nothing Then If layout_changed = False Then SendKeys "%+" layout_changed = True End If Else If layout_changed = True Then SendKeys "%+" layout_changed = False End If End If End Sub جرب ارجو ان يزبط معك مانفست كلابشة_1.rar

إضغط الملف المعني ثم إرفقه في المشاركه

السلام عليكم انسخ الكود في مودويل ' اسم الملف الإفتراضي المراد Private Const إسم_الملف_الإفتراضي As String = "Ali_x.xls" ' مسمى المودويل المدرج فيه الماكرو Private Const المودويل As String = "Module1" ' الماكرو المراد حذفه اذا تغير مسمى الملف الإفتراضي Private Const مسمى_الماكرو As String = "dd" Sub auto_open() On Error Resume Next If ThisWorkbook.Name <> إسم_الملف_الإفتراضي Then Set V_C = ActiveWorkbook.VBProject.VBComponents(المودويل).CodeModule If Err.Number <> 0 Then MsgBox ("المودويل : " & المودويل & vbCr & "غير موجود في الملف الحالي") Exit Sub End If S_l = V_C.ProcStartLine(مسمى_الماكرو, vbext_pk_Proc) If Err.Number <> 0 Then MsgBox ("الماكرو " & "Sub " & مسمى_الماكرو & "( )" & vbCr _ & المودويل & " : غير موجود في.") Else MsgBox "بسبب تغير اسم الملف" & مسمى_الماكرو & "تم حذف ماكرو", vbInformation, "" End If With V_C Num_l = .ProcCountLines(مسمى_الماكرو, vbext_pk_Proc) .DeleteLines StartLine:=S_l, Count:=Num_l End With Else End If End Sub

الاستاذ القدير بن عليه معادلات في منتهى الروعه " نابغ المعادلات الصعبة"

السلام عليكم بعد اذن اخي الحبيب ضاحي المرفق به ماتريد أولاً إملاء عمود "O" من بعد السطر الأول بالإختصارات المرغوب إستخدامها ومن ثم إفتح الفورم وعند تحديد مربع "وذلك عن " = TxDescription إضغط زر "F11" ويليه مباشرة "F12" لعمل كومبوكس وبه الإختصارات المدرجة سابقاً في عمود "O" + فتح القائمة ( "F12" أو كليك على الكموبكس ) لـ فتح القائمة ( كـاإختصار ) بعدها إنقر على البيان المراد من الليسته ينضاف ديركت في مربع "وذلك عن " أرجو ان يفي بالغرض khaledkhaleel_1.rar

اخي الحبيب قنديل الصياد لاحظ بيانات ورقة الرصد "لصف ثالث اخر العام " لرقم جلوس "33" و "71" المشار اليهم في عمود "النتيجة العامه للطالب" في عمود "V" = "دور ثان" ولاكن مشار اليهم "النتيجة العامه للطالب" ناجح والشرط في الكود حسب عمود "النتيجة العامه للطالب" ربما المشكله في المعادلة

اذا نتائج البحث عدة خامات اضن ادخال شرط الخامه المراد حصرها من نتائج البحث بكمبوكس يكون افضل حسب فهمي للطلب ومن ثم بعد ادخال الشرط يعرض النتائج في Lisbox2 هل هذا ماتريد ؟

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

تفضل اخي الكريم جرب الملف ارفقناه على الرابط التالي ارجو ان يكون زبط معك

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

طلبك معقد حبتين المشكلة التي لديك تعتبر من افتراضيات جداول الاكسل تحذف تضيف تتغير المواقع سواء للاعمده او للصفوف سبق ان حاولت التحايل على هذه المشكله وهو اضافة سطر جديد للاجماليات عند الطباعه فقط وحذفه بعد الطباعه راجع الرابط التالي http://www.officena.net/ib/index.php?showtopic=44377&hl=hpagebreaks

اخي الحبيب قنديل الصياد " رصد ثالث اخر العام " و " ناجحون صف ثالث اخر العام " " راسبون صف ثالث اخر العام " جداول المواد للصفوف "اول" و "ثاني" و "رابع" و "خامس" و"سادس" ليس بها عمود التقدير لكل مادة اما " ثالث" التقدير موجود للناجحين والراسبين / وفي رصد ثالث غير موجود وبرضه عمود "التقدير العام" موجود للناجحين والراسبين / وفي رصد ثالث غير موجود ارجو ان تكون وضحت لديك الصورة والاصح تحذف الاعمدة لانها فريده غير مطبقة على الصفوف البقيه او احاول اعدلك على الكود بحيث يتجاوز عمود " التقدير " للصف الثالث

السلام عليكم كما تفضل اخونا رعد شرحك في الملف تريد تنفيذ الكود سواء الورقة محمية او غير محميه Private Sub Worksheet_Change(ByVal Tr As Range) On Error Resume Next Set Rn = [B1:B17] If Not Rn Is Nothing Then Sheet1.Unprotect "123" Rn.SpecialCells(4)(1).Value = "0" Sheet1.Protect "123" End If End Sub

عمود " التقدير العام " موجود في ورقة الناجحين والراسبين وغير موجود في الرصد وعمود " التقدير " لكل مادة موجود في الناجحين والراسبين وغير موجود في الرصد هذا سبب ترحيل ونقص بعض اعمد مادة " التربية دينية "

بامكانك تعديل مسمى الورقة او ينفذ الكود على الورقة الفعاله With ActiveSheet بدلا من With Sheet1

السلام عليكم بعد اذن اخي الحبيب ابو حنين عملت على الكود رغم ان تعديل الاستاذ ابو حنين ادى الغرض لاكن حاولت ان اربط اكواد الصفوف كامله بكود الكود فعال مع الملف الذي على الرابط التالي http://www.gulfup.com/?Yd7S3C لوجود اختلاف في تسميات الاوراق وتم تعديله على الملف المرفق في الرابط وهذا الكود النهائي Private Const Rsb As String = "راسبون" Private Const Na_h As String = "ناجحون" Private Const Rs As String = "راسب" Private Const Ng As String = "ناجح" Private Const D_2 As String = "له دور ثانى" Private Const D_1 As String = "له دور ثان" Public Sub A_Tr() Dim Sn As Worksheet Set Sn = ActiveSheet With Sn 'On Error Resume Next Select Case .CodeName Case Is = "ورقة36": Cl = 77 Case Is = "ورقة40": Cl = 77 Case Is = "ورقة41": Cl = 68 Case Is = "ورقة42": Cl = 85 Case Is = "ورقة43": Cl = 85 Case Is = "ورقة44": Cl = 85 End Select En_S False La = .Cells(.Rows.Count, 1).End(xlUp).Row With Sheets(S_Nm(.Name, "N")) .Range(.Cells(14, 1), .Cells(1000, Cl + 2)).ClearContents End With With Sheets(S_Nm(.Name, "R")) .Range(.Cells(14, 1), .Cells(1000, Cl + 2)).ClearContents End With rr = 14: R2 = 14: Rw = 1: Rw2 = 1 For R = 14 To La Cll = IIf(Cl = 85, 3, 6) If .Cells(R, Cl).Value = Ng And .Cells(R, 2).Value <> "" Then Union(.Range(.Cells(R, 2), .Cells(R, 3)), .Range(.Cells(R, Cll), .Cells(R, Cl + 3))).Copy Sheets(S_Nm(.Name, "N")).Range("B" & rr).PasteSpecial xlPasteValues Sheets(S_Nm(.Name, "N")).Range("A" & rr) = Rw Application.CutCopyMode = False rr = rr + 1: Rw = Rw + 1 ElseIf (.Cells(R, Cl).Value = Rs Or .Cells(R, Cl).Value = "غ" Or .Cells(R, Cl).Value = D_1 Or _ .Cells(R, Cl).Value = D_2) And .Cells(R, 2) <> "" Then Union(.Range(.Cells(R, 2), .Cells(R, 3)), .Range(.Cells(R, Cll), .Cells(R, Cl + 3))).Copy Sheets(S_Nm(.Name, "R")).Range("B" & R2).PasteSpecial xlPasteValues Sheets(S_Nm(.Name, "R")).Range("A" & R2) = Rw2 Application.CutCopyMode = False R2 = R2 + 1: Rw2 = Rw2 + 1 End If Next En_S True End With End Sub Private Function S_Nm(N$, i$) Dim Sh As Worksheet Dim Sm$ a = IIf(i = "R", Rsb, Na_h) For Each Sh In ThisWorkbook.Worksheets Nm = Sh.Name If Mid(Nm, 1, 6) = a And Mid(Nm, 10, Len(Nm)) Like "*" & Mid(N, 5, Len(N)) Then Sm = Sh.Name Exit For End If Next S_Nm = Sm End Function Private Function En_S(B As Boolean) With Application .Calculation = IIf(B, -4105, -4135) .ScreenUpdating = B .EnableEvents = B End With End Function اربط الكود باازرار اوراق الرصد

اخي قنديل الصياد معادلة " النتيجة العامة للطالب " لنصف العام تختلف عن معادلة " النتيجة العامة للطالب " لاخر العام اخر العام غ / ناجح / له دور ثانى =IF(OR(CA14="غ");"غ";IF(AND(CA14>=160;SUM(K14)>=K$13;SUM(T14)>=T$13;SUM(AC14)>=AC$13;SUM(AK14)>=AK$13;SUM(AS14)>=AS$13;SUM(BB14)>=BB$13;SUM(BJ14)>=BJ$13;SUM(BS14)>=BS$13);"ناجح";"له دور ثانى")) نصف العام غ / ناجح / راسب =IF(OR(BK14="غ");"غ";IF(AND(BK14>=400;SUM(J14)>=J$13;SUM(Q14)>=Q$13;SUM(X14)>=X$13;SUM(AD14)>=AD$13;SUM(AJ14)>=AJ$13;SUM(AQ14)>=AQ$13;SUM(AW14)>=AW$13;SUM(BD14)>=BD$13);"ناجح";"راسب")) هل " له دور ثانى " يحتسب كـ راسب ؟

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

اخي الكريم قنديل الصياد اولا تأكد من مسميات الأوراق بعضها التسميه خاطئه ثم الصق الكود التالي في مودويل وإستدعيه من اوراق رصد Private Const Rsb As String = "راسبون" Private Const Na_h As String = "ناجحون" Private Const Rs As String = "راسب" Private Const Ng As String = "ناجح" Public Sub A_Tr() Dim Sn As Worksheet Set Sn = ActiveSheet With Sn On Error Resume Next Select Case .CodeName Case Is = "ورقة36" Cl = 77 Case Is = "ورقة40" Cl = 77 Case Is = "ورقة41" Cl = 68 Case Is = "ورقة42" Cl = 85 Case Is = "ورقة43" Cl = 85 Case Is = "ورقة44" Cl = 85 End Select En_S False La = .Cells(.Rows.Count, 1).End(xlUp).Row Sheets(S_Nm(.Name, "N")).Range("a14:ca1000").ClearContents Sheets(S_Nm(.Name, "R")).Range("a14:ca1000").ClearContents rr = 14: R2 = 14 For R = 14 To La If .Cells(R, Cl).Value = Ng And .Cells(R, 2).Value <> "" Then Union(.Range(.Cells(R, 2), .Cells(R, 3)), .Range(.Cells(R, 6), .Cells(R, Cl + 2))).Copy Sheets(S_Nm(.Name, "N")).Range("B" & rr).PasteSpecial xlPasteValues Application.CutCopyMode = False rr = rr + 1 ElseIf (.Cells(R, Cl).Value = Rs Or .Cells(R, Cl).Value = "غ") And .Cells(R, 2) <> "" Then Union(.Range(.Cells(R, 2), .Cells(R, 3)), .Range(.Cells(R, 6), .Cells(R, Cl + 2))).Copy Sheets(S_Nm(.Name, "R")).Range("B" & R2).PasteSpecial xlPasteValues Application.CutCopyMode = False R2 = R2 + 1 End If Next En_S True End With End Sub Private Function S_Nm(N$, i$) Dim Sh As Worksheet Dim Sm$ A = IIf(i = "R", Rsb, Na_h) For Each Sh In ThisWorkbook.Worksheets Nm = Sh.Name If Mid(Nm, 1, 6) = A And Mid(Nm, 10, Len(Nm)) Like "*" & Mid(N, 5, Len(N)) Then Sm = Sh.Name Exit For End If Next S_Nm = Sm End Function Private Function En_S(B As Boolean) With Application .Calculation = IIf(B, -4105, -4135) .ScreenUpdating = B .EnableEvents = B End With End Function ارجو التجربه ملاحظه شرط ناجح او راسب او غائب إعتمادً على عمود " النتيجة العامة للطالب" في أوراق الرصد

الاخ الفاضل قنديل الصياد مع كثر صفحات البرنامج الواحد يتوه وليس لي درايه في اعمال كنترول المدارس ارجو منك توضيح الطلب ماهي اوراق اخر العام هل هيا من ( صف اول اخر العام ) الى ( صف سادس اخر العام ) والتقييم الاخير للطالب مثلا صف اول من ورقة ( رصد اول اخر العام ) عمود ( النتيجة العامة للطالب ) يترحل منها الناجح الى ( ناجحون صف اول اخر العام ) والراسب الى ( راسبون صف اول اخر العام ) هذا مافهمته بعد تصفح الملف والسموحه منك للتأخر في الرد

حسب فهمي لما تريد اذا اردت ملفات بنفس الفولدر حفز مربع الاختيار وانقر على الزر جرب المرفق ‫حذف ملفات_A - 1.rar

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

وعليكم السلام ورحمة الله وبركاته استاذي الحبيب احمد زمان لااعلم ان كنت فعلت المرجع من قائمة References اذا لم يفعل ضيف هذه السطرين اول كود Imp_Scan لتفعيل مرجع اداة WIA On Error GoTo nxt Set Ref_Ad = ThisWorkbook.VBProject Ref_Ad.References.AddFromFile "C:\Windows\system32\wiaaut.dll" nxt: انا اعمل حاليا على اوفيس 2007 والكود شغال معي وهذا الكود وبه الاضافه السابقة Private Sub Imp_Scan() On Error GoTo nxt Set Ref_Ad = ThisWorkbook.VBProject Ref_Ad.References.AddFromFile "C:\Windows\system32\wiaaut.dll" nxt: Dim W_A As New WIA.ImageFile Dim WD_A As New WIA.CommonDialog Dim WS_A As WIA.Device On Error GoTo Er_a Set WS_A = WD_A.ShowSelectDevice Dim Path_F$ Dim Ar As Variant Dim i, n, A_M Dim x(100) As Integer Dim Ar_Max& Dim Start%, Last%, Num% On Error Resume Next Path_F = ThisWorkbook.Path & Application.PathSeparator 'Path_F = "C:\" & "Ali" M_v = Ali_List(Path_F) If TypeName(M_v) <> "Boolean" Then For i = LBound(M_v) To UBound(M_v) M_v(i) = Ali_Re(M_v(i)) Next Start = LBound(M_v): Last = UBound(M_v) Num = Last - Start + 1 For i = Start To Last x(i) = M_v(i) Next i Ar_Max = x(Start) For n = Start + 1 To Last If x(n) > Ar_Max Then Ar_Max = x(n) Next n Else End If If Ali_List(Path_F) = False Then A_M = 1 With WS_A.Items(1) .Properties("6146").Value = 4 .Properties("6147").Value = 100 .Properties("6148").Value = 100 .Properties("6149").Value = 0 .Properties("6150").Value = 0 .Properties("6151").Value = 830 .Properties("6152").Value = 1167 Set W_A = .Transfer(wiaFormatJPEG) End With '************************************************************* If Ar_Max = 0 Then Ar_Max = 1 Else A_M = Ar_Max + 1 End If If Dir(ThisWorkbook.Path & "\A_M.jpg") <> "" Then Kill ThisWorkbook.Path & "\A_M.jpg" End If ''************************************************************** W_A.SaveFile (Path_F & "\" & A_M & "A_M.jpg") Erase x MsgBox "تم قراءة الصوره من الاسكنر بنجاح", vbInformation, "" Set W_A = Nothing Set WS_A = Nothing Exit Sub Er_a: MsgBox ("تأكد من توصيل الماسح الضوئي"), , "تنبية !!!" End Sub ارجو التجربه وان شاء الله يعمل معك

او كالتالي Sub m() N = Array("1", "2") For i = 0 To UBound(N) Sheets(N(i)).Range("a4,b6").ClearContents Next End Sub

السلام عليكم جرب المرفق امل ان يفي بالغرض حدد نوع او صيغة ملفات الاكسل اول الكود ' نوع ملفات الاكسل المراد حذفها Private Const S As String = ".xlsx" حذف ملفات_A.rar