سليم حاصبيا

تم التعديل باضافة سطر واحد علة الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Column <> 2 Or Target.Row < 2 Or Target.Cells.Count > 1 Then Application.EnableEvents = True: Exit Sub End If ActiveSheet.Unprotect Cells(Target.Row, 3).Locked = False If IsNumeric(Target) And Target >= 10 Then Cells(Target.Row, 3) = "" Cells(Target.Row, 3).Locked = True ActiveSheet.Protect End If Application.EnableEvents = True End Sub

جرب هذا الملف الماكرو مرفق Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Column <> 2 Or Target.Row < 2 Or Target.Cells.Count > 1 Then Application.EnableEvents = True: Exit Sub End If ActiveSheet.Unprotect Cells(Target.Row, 3).Locked = False If IsNumeric(Target) And Target >= 10 Then Cells(Target.Row, 3).Locked = True ActiveSheet.Protect End If Application.EnableEvents = True End Sub Demand Macro_salim.rar

انسخ هذه المعادلة الى الخلية C2 في ورقة Main استعملها مع Ctrl+Shift+Enter ثم اسحبها نزولاً =INDEX('قائمة حساب الفواتير'!$D$2:$D$500,MAX(IF($B2='قائمة حساب الفواتير'!$B$2:$B$500,ROW($B$2:$B$500)-1,0)))

تم التعديل على الملف يحيث لا يقبل تكرار الكود My_codes_salim.rar

حيث ان اللائحة عندك طويلة جداَ و لا يوجد وقت لاكمال هكذا اعمال ربما تجد المساعدة في هذا الملف يمكنك تعديل الكود حسب ما تريد ليتناسب مع الملف عندك يرجى في المرات القادمة اختصار الملف الى (10- 15)صف مع عدم الزركشة (ألوان و تنسيقات تبهر الناظر اليها وتمنعه من التركيز على البيانات) My_codes.rar

جرب هذا الملف Nag_Ras.rar

اخي باسر تم حذف النطاق المطلوب و لم الحظ اي شيء غير عادي اليك المرفق Report_salim1.rar

تم معالجة امر بشكل صحيح انظر الى الورقة Report Report_salim.rar

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

بعد اذن اخي ياسر ربما يكون المطلوب (معادلات) انظر الى الصفحة Salim Report_salim.rar

ربما ينفع هذا الكود Option Explicit Sub Tarhil() Dim First, Sec As Worksheet Dim m, n, x As Long Set First = Sheets("تسجيل الدرجات") Set Sec = Sheets("دور ثاني") m = 11 Application.ScreenUpdating = False For n = 6 To 154 x = 2 * n - 1: Sec.Range("E" & x & ":CT" & x).ClearContents Next For n = 8 To x - 2 If First.Cells(n, 3) = "راسب" Then Sec.Range("E" & m).Resize(1, 95).Value = First.Range("D" & n).Resize(1, 95).Value m = m + 2 End If Next Application.ScreenUpdating = True MsgBox ("That Is All ") End Sub

ربما كان المطلوب Info_Move_salim.rar

المعادلة المطلوبة IF(C2="","",VLOOKUP(C2,{0,0.25;500000,0.3;750000,0.35},2)*C2)=

يجب علي ماكرو المسح في صفجة بيانات الطلا ب ان لا ينفذ الا على هذه الصفخة بالذات لذلك تداركاً للخطأ يجل علينا وضع سطر في الكود If ActiveSheet.Name <> "بيانات الطلاب" Then Exit Sub ليصيح الكود هكذا Sub ClearConstantsOnly() 'كود مسح البيانات و الحفاظ على المعادلات If ActiveSheet.Name <> "بيانات الطلاب" Then Exit Sub prompt = "هل حقا تريد مسح كل البيانات!؟" Command_buttons = vbYesNo + VbMsgBoxRt1Reading Title = "تحذير. انتبه !!!!" project = MsgBox(prompt, Command_buttons, Title) If project = vbYes Then On Error Resume Next Range("c17:g516").SpecialCells(xlCellTypeConstants).ClearContents Range("A1").Select End If End Sub

انسخ هذا المعادلة الى الخلية B1 واسجب نزولاً =IF(A1="","",VLOOKUP(A1,{1,1425;250,1400;490,1350;750,1300;1000,1290},2)) و اذا لم تضبط معك استبدل الفاصلة "," بفاصلة منقوطة ";" في المعادلة أو العكس(حسب اعدادات الجهاز عندك ) لتصبح هكذا =IF(A1="";"";VLOOKUP(A1;{1,1425;250,1400;490,1350;750,1300;1000,1290};2))

لم افهم من الملف ماذا تريد هل ان عملية النقل تتعلق بتاريخ معين لكل الاسماء او بين تاريخين لاسم معين ام تريد No paid أو Paid فقط باسم معين (لكل الاسماء)

ارفع ملفاً للعمل عليه و افادتك بالحل

كود اخر بواسطة Loop انتبه الى الملاحظات في اسفل الكود بواسطة هذه المعادلات لا تتأثر الخلايا في حال زيادة صفوف او حذف صفوف (قبل الصف 12)من الورقة أو اذا تم حذف اي اسم من لائحة الفصل لا يتأثر الترقيم في كلا العامودين اذا كنت قد فهمت الكود اليك هذا المهمة تنزيل كود اخر بحيث: 1-يعمل على المتغير I بواسطة Loop (من 1 الى 10) * عدد الفصول 2-يعمل على المتغير K بواسطة Loop (من 17 الى اخر صف في الورقة Main) * هذا الخاصية موجودة في الكود المرفق 3- يقوم بترقيم التلاميد بدون معادلات في العامودين I & C في كل ورقة من ورقات الصفوف Option Explicit Sub tanslate_data_salim_loop() Dim My_Sh As Worksheet Dim lr1, i, k, m, col, y As Integer Dim my_rg, cel As Range Application.ScreenUpdating = False Application.Calculation = xlCalculationManual lr1 = Main.Cells(Rows.Count, "c").End(3).Row Set my_rg = Main.Range("c17:g" & lr1) For i = 1 To 10 m = 0 Set My_Sh = Sheets(i & "") My_Sh.Range("d12:g36").ClearContents My_Sh.Range("i12:l36").ClearContents k = 17 Do Until k = lr1 + 1 'يمكنك استعمال هذا السطر ' Do While k <= lr1 'او هذا السطر Select Case m Case Is < 25 col = m + 12 y = 4 Case Else col = m - 13 y = 9 End Select If Main.Cells(k, "g") = i Then My_Sh.Cells(col, y).Resize(1, 4).Value = Main.Cells(k, 3).Resize(1, 4).Value m = m + 1 End If k = k + 1 Loop Next Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' ملاحظات ' بالنسبة للمعادلات في صفحات الصفوف 'الافضل كتابة هذه المعادلة في الخلية 'C12: '=IF(D12="","",MAX($C$11:C11)+1) 'ثم اسحب نزولاً 'و هذه المعادلة في الخلية 'I12: '=IF(I12="","",MAX(C:C)+ROWS($A$1:A1)) 'ثم اسحب نزول '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

رائع التعديل الذي وضعته على الكود انا بدوري وضعت لك تعديلاً اخر بواسطة الحلقات التكرارية (يمكن استعمالها جيث انه لا خلايا مدمجة) مرفق الكود (الصف الاعدادي الاول) (بدون حلقات تكرارية) يعتمد على Resize او الكود الثاني ***** حلقات تكرارية مع اقتراح نسخ احدهما الى بقية المصنفات حيث انه اسرع Option Explicit Sub tanslate_data_salim1() Dim My_Sh As Worksheet Dim lr1, i, k, m, col, y As Integer Dim my_rg, cel As Range Application.ScreenUpdating = False Application.Calculation = xlCalculationManual lr1 = Main.Cells(Rows.Count, "c").End(3).Row Set my_rg = Main.Range("c17:g" & lr1) For i = 1 To 10 m = 0 Set My_Sh = Sheets(i & "") My_Sh.Range("d12:g36").ClearContents My_Sh.Range("i12:l36").ClearContents For k = 17 To lr1 Select Case m Case Is < 25 col = m + 12 y = 4 Case Else col = m - 13 y = 9 End Select If Main.Cells(k, "g") = i Then My_Sh.Cells(col, y).Resize(1, 4).Value = Main.Cells(k, 3).Resize(1, 4).Value m = m + 1 End If Next Next Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Option Explicit Sub tanslate_data_salim() Dim My_Sh As Worksheet Dim lr1, i, k, m, x As Integer Dim my_rg, cel As Range Application.ScreenUpdating = False Application.Calculation = xlCalculationManual lr1 = Main.Cells(Rows.Count, "c").End(3).Row Set my_rg = Main.Range("c17:g" & lr1) For i = 1 To 10 m = 0 Set My_Sh = Sheets(i & "") My_Sh.Range("d12:g36").ClearContents My_Sh.Range("i12:l36").ClearContents For k = 17 To lr1 '======================= Select Case m Case Is < 25 If Main.Cells(k, "g") = i Then For x = 0 To 3 My_Sh.Cells(m + 12, 4).Offset(, x) = Main.Cells(k, 3).Offset(, x) Next m = m + 1 End If Case Else If Main.Cells(k, "g") = i Then For x = 0 To 3 My_Sh.Cells(m - 13, 9).Offset(, x) = Main.Cells(k, 3).Offset(, x) Next m = m + 1 End If End Select Next Next Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub

الكود اللازم Private Sub Text2_Change() If CheckBox1 = True Then Text2.PasswordChar = "*" Else Text2.PasswordChar = "" End If End Sub

جرب هذا الملف t1 Salim.rar

استعمل الملف الذي رفعتة لك لان اسماء الصفحات متغيرة او ربما كانت عناوين الخلايا التي تبدأ فيها البيانات عندك في الصفحة Mainمتغيرة

تفضل يا صديقي هذا اقصى ما توصلت اليه تم تغيير اسماء الصفحات المعنية لحسن العمل مع اللغة الاجنبية(فقط اضغط على الزر في صفحة Main) ثم تفقد باقي الصفحات الكود (يأخذ وقتاً لانه طويل قليلاً) Sub Filter_Me(x) Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Sheets("Sapace").Range("b4:g200").ClearContents With Sheets("Main") .Range("$B$16:$g$434").AutoFilter Field:=6, Criteria1:="=" & x .AutoFilter.Sort.SortFields.Add Key:=Range("C16:C434") .Range("b16:g434").SpecialCells(12).Copy Destination:=Sheets("Sapace").Range("b4") .Range("$B$16:$g$434").AutoFilter End With Sheets("Sapace").Select lrx = Sheets("Sapace").Cells(Rows.Count, "b").End(3).Row Range("D4").Select Selection.AutoFilter ActiveWorkbook.Worksheets("Sapace").AutoFilter.Sort.SortFields.Clear ActiveWorkbook.Worksheets("Sapace").AutoFilter.Sort.SortFields.Add Key:=Range _ ("D4:D" & lrx), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ xlSortTextAsNumbers With ActiveWorkbook.Worksheets("Sapace").AutoFilter.Sort .Apply End With Selection.AutoFilter With Sheets(x & "") ro1 = .Cells(Rows.Count, "d").End(3).Row ro2 = .Cells(Rows.Count, "i").End(3).Row ro = Application.Max(ro1, ro2) .Range("d12:g" & ro).ClearContents .Range("i12:L" & ro).ClearContents y = Int(lrx / 2): m = 12 For tt = 1 To 2 Select Case m Case Is <= y .Cells(12, 4).Resize(y - 4, 4).Value = Sheets("Sapace").Range("c5:f" & y).Value m = y + 1 Case Else .Cells(12, 9).Resize(m, 4).Value = Sheets("Sapace").Range(Cells(lrx - y, 3), Cells(lrx, 6)).Value End Select Next End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Sub Give_data() 'توزيع النلاميذ مع الابجدة الاتاث أولا For i = 1 To 10 Filter_Me (i) Next End Sub st distribution_with aphab femel_first.rar

جرب هذا الملف للفرز والابجدة الكود مرفق Sub Filter_Me(x) Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Sheets("Sapace").Cells.Clear With Sheets("Main") .Range("$B$4:$G$434").AutoFilter Field:=6, Criteria1:="=" & x .AutoFilter.Sort.SortFields.Add Key:=Range("C4:C434") .Range("b4:g434").SpecialCells(12).Copy Destination:=Sheets("Sapace").Range("b4") .Range("$B$4:$G$434").AutoFilter End With lrx = Sheets("Sapace").Cells(Rows.Count, "b").End(3).Row With Sheets(x & "") .Range("b5:g50").ClearContents .Cells(5, 2).Resize(lrx, 6).Value = Sheets("Sapace").Range("b5:g" & lrx).Value .Columns.AutoFit End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Sub Give_data() For i = 1 To 10 Filter_Me (i) Next End Sub correction_stds.rar

المشكلة ان الاسماء موجودة في خلايا مدمجة (الاعمدة D E F)مما يعيق عملية الترتيب الابجدي للتلاميذ كي تتم عملية الابجدة يجب كتابة الاسماء في عامود واحد دون استعمال عدو الاكواد الاول(أعني الخلايا المدمجة) انا لا اعرف لماذا تستعملون الخلايا المدمجة في حين يمكن توسيع العامود بالقدر الذي تريد لاستيعاب المعلومات