سليم حاصبيا

جرب هذا الملف الصراحة الكود مقتبس ولا أعرف واضعه Moukhalafat.xlsm

rigth Click على اي زر من الازرار ثم Assign Macro ثم Edit

حسب ما فهمت من السؤال ربما يكون هذا الملف نموذج عما تريد اذا ادركت انك ادرجت اسماً بالخطأ اضغط على الزر Undo كلما ضغطت مرة على Undo تستطيع أن تمسح اخر تسجيل في الصفحة الثانية اذا اردت مسح كل البيانات من الصفحة الثانية اضغط على الزر Clear Data Direct to Other_Sheet.xlsm

صديقي تستطيع ان تحصل على نفس النتيجة من خلال هذه المعادلة (بدون 6 مسلسلات من شروط IF ) اذ ربما كان هناك 50 شرط او اكثر =C3+LOOKUP(B3;{1;10;25;50;100};{0.5;1;1.5;2;3}) اذا لم تعمل معك المعادلة استبدل الفاصلة المنقوطة " ; " بفاصلة عادية " , " خارج الأقواس فقط { } اما داخل الاقواس لك حق الاختيار او تغيرها كلها او تبقيها كلها لتبدو المعادلة هكذا =C3+LOOKUP(B3,{1;10;25;50;100},{0.5;1;1.5;2;3}) في القوسين الاولين الشروط وفي القوسين الباقيين النتيجة (ترتيب الارقام من الأصغر للأكبر داخل أقواس الشروط ضروري)

بعد اذن اخي علي ليس هناك من حاجة لهذا المسلسل من IF رجاء ملاحظة الملف التالي mosalsal.xlsx

تطوير بسيط على الكود ليكون بشكل أسرع بكثير معتمداً على الفلتر وليس الحلقات التكرارية المملة والمرهقة للبرنامج و اضافة الى ذلك ترقيم تلقائي للطلاب Option Explicit Sub get_Eleves_Names(ByVal my_SHEET As String) Rem ====>>>> Created By Salim Hasbaya On 27/6/2019 Application.ScreenUpdating = False '================================ Dim SH As Worksheet Dim ss% For Each SH In Sheets If SH.Name Like "*#*" Then ss = ss + 1 End If Next Set SH = Nothing '============================ Dim m As Worksheet: Set m = Sheets("Main") Dim But_Sheet As Worksheet: Set But_Sheet = Sheets(my_SHEET) But_Sheet.Range("K1") = ss: ss = 0 Dim Ar(4), Ar_Fasl(1 To 9) Dim t: t = Sheets(my_SHEET).Index Dim Start_row_B%: Dim Start_row_H% Dim mal$: mal = "ذكر" Dim fem$: fem = "انثى" Dim i% But_Sheet.Range("B10").Resize(500, 5).ClearContents But_Sheet.Range("H10").Resize(500, 5).ClearContents '======================================= Dim Filtred_rg As Range: Set Filtred_rg = m.Range("a1").CurrentRegion Dim FinaL_row%: FinaL_row = Filtred_rg.Rows.Count For i = 4 To 12 Ar_Fasl(i - 3) = CStr(But_Sheet.Cells(5, i)) Next With Filtred_rg .AutoFilter 2, mal .Columns(8).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("B10") .Columns(7).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("d10") .Columns(1).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("e10") .Columns(3).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("f10") End With '======================================= With Filtred_rg .AutoFilter 2, fem .Columns(8).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("h10") .Columns(7).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("j10") .Columns(1).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("k10") .Columns(3).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(xlCellTypeVisible).Copy But_Sheet.Range("L10") End With Start_row_B = But_Sheet.Cells(Rows.Count, "B").End(3).Row Start_row_H = But_Sheet.Cells(Rows.Count, "H").End(3).Row But_Sheet.Range("c10").Resize(Start_row_B - 9) = _ Application.Transpose(Ar_Fasl(t - 1)) But_Sheet.Range("i10").Resize(Start_row_H - 9) = _ Application.Transpose(Ar_Fasl(t - 1)) But_Sheet.Columns("A:L").AutoFit '================================ If Sheets("Main").FilterMode Then _ Sheets("Main").ShowAllData: Filtred_rg.AutoFilter Set m = Nothing: Set But_Sheet = Nothing Erase Ar: Erase Ar_Fasl Application.ScreenUpdating = True End Sub '================================================== Sub EXTACCT_NAME() Dim Impt Dim x% Impt = InputBox("Please Give_me the sheet's name to transfer data" & _ Chr(10) & "Write the sheet's name Without Cotes") If UCase(Impt) = "MAIN" Then MsgBox "I can't Change the values of Principal Sheet" Exit Sub End If On Error Resume Next x = Len(Sheets(Impt).Name) If x = 0 Then On Error GoTo 0 MsgBox "The Sheet: " & Impt & " Not Existes" Exit Sub End If Call get_Eleves_Names(Impt) End Sub الملف من جديد Mes_Eleves_Super.xlsm

جرب هذا الملف My_search.xlsm

لا حاجة لعدد من الزرار يساوي عدد الشيتات الكود Option Explicit Sub get_Eleves_Names(ByVal my_SHEET As String) Rem ====>>>> Created By Salim Hasbaya On 27/6/2019 '================================ Dim y%, SH As Worksheet Dim ss%: ss = 0 For y = 1 To Sheets.Count If Sheets(y).Name Like "*#*" Then ss = ss + 1 End If Next '============================ Dim m As Worksheet: Set m = Sheets("Main") Dim Fst As Worksheet: Set Fst = Sheets(my_SHEET) Dim Ar(4), Ar_Fasl(1 To 9) Dim t: t = Sheets(my_SHEET).Index Dim lrA%: lrA = m.Cells(Rows.Count, "A").End(3).Row Dim lrF%: lrF = m.Cells(Rows.Count, "F").End(3).Row Dim mal$: mal = "ذكر" Dim fem$: fem = "انثى" Dim i% Dim Start_row_B%: Start_row_B = 10 Dim Start_row_H%: Start_row_H = 10 Fst.Range("b10").Resize(500, 11).ClearContents With m For i = 2 To lrA Ar(0) = .Cells(i, "H"): Ar(1) = "" Ar(2) = .Cells(i, "G"): Ar(3) = .Cells(i, "A") Ar(4) = .Cells(i, "C") If .Range("B" & i) = mal Then Fst.Cells(Start_row_B, "B").Resize(, UBound(Ar) + 1) = Ar Start_row_B = Start_row_B + 1 ElseIf .Range("B" & i) = fem Then Fst.Cells(Start_row_H, "H").Resize(, UBound(Ar) + 1) = Ar Start_row_H = Start_row_H + 1 End If Next For i = 4 To 12 Ar_Fasl(i - 3) = CStr(Fst.Cells(5, i)) Next Fst.Range("c10").Resize(Start_row_B - 10) = _ Application.Transpose(Ar_Fasl(t - 1)) Fst.Range("I10").Resize(Start_row_H - 10) = _ Application.Transpose(Ar_Fasl(t - 1)) Fst.Range("K1") = ss End With Set m = Nothing: Set Fst = Nothing Erase Ar: Erase Ar_Fasl End Sub '================================================== Sub EXTACCT_NAME() Dim Impt Dim x% Impt = InputBox("Please Give_me the sheet's name to transfer data" & _ Chr(10) & "Write the sheet's name Without Cotes") If Impt = "Main" Then MsgBox "I can't Change the values of Principal Sheet" Exit Sub End If On Error Resume Next x = Len(Sheets(Impt).Name) If x = 0 Then On Error GoTo 0 MsgBox "The Sheet: " & Impt & " Not Existes" Exit Sub End If Call get_Eleves_Names(Impt) End Sub يكفي زر واحد و الماكرو يطلب منك اسم الشيت التي تريد الترحيل اليها مثل هذه الصورة(كتابة اسم الشيت بدون الأقواس) الملف مرفق للمعاينة وابداء الرأي Mes_Eleves_new.xlsm

يمكنك متابعة هذه الصور لمعرفة كيف يتم ذلك (بدون اي كود) اذا اردتها بالماكرو الكود Sub hide_tabs() ActiveWindow.DisplayWorkbookTabs = False End Sub لاعادة اظهارها استبدل False بـــ True

ربما هكذا Explain_2.xlsx

تفضل هذا المزيد Mult_by_choise.xlsx

اذا اردتها عاموديا اكتب هذا المعادلة(اينما تريد) واسحبها نزولاً =ROWS($A$1:A1)*50 اذا اردتها افقياً اكتب هذا المعادلة(اينما تريد) واسحبها بالعرض =COLUMNS($A$1:A1)*50

جرب هذا الملف Explain.xlsx

تم التعديل My_date_new.xlsm

بارك الله بك اخي مصطفى وهذا عمل اخر يقوم بنفس الشيء لكن بدالة معرفة UDF الكود بداية Option Explicit Function Salim_Split_Name(N_name, n) Dim x% Dim arr: arr = _ Array("سيف", "عبد", "أبو", "ابو", "عز", _ "صدر", "نور", "فضل") '++++++++++++++++++++++++++++++++++++++ Rem Array تستطيع ان تضيف اي بداية اسم مركب داخل هذا الــ '+++++++++++++++++++++++++++++++++++++ Dim My_Col As New Collection Dim Final_col As New Collection Dim it, my_st, my_name my_st = Trim(N_name) my_name = Split(Trim(my_st)) For x = LBound(my_name) To UBound(my_name) My_Col.Add my_name(x) Next x For x = 1 To My_Col.Count If Not (IsError(Application.Match(My_Col(x), arr, 0))) Then Final_col.Add My_Col(x) & " " & My_Col(x + 1) x = x + 1 Else Final_col.Add My_Col(x) End If Next x If n > Final_col.Count Then Salim_Split_Name = "" Else Salim_Split_Name = Final_col(n) End If Set My_Col = Nothing: Set Final_col = Nothing Erase arr End Function نموذج عن الدالة وكيفية عملها في الملف المرفق Fuction_split_name.xlsm

معادلة واحدة على كل العامود(دون ادراج معادلة في الصف الاول مختلفة) في الخلية E2 =IF(COUNTA($C2:$D2)=0,"",SUM($C2,-$D2)+SUM($E1)) اذا لم تعمل المعادلة معك استبدل الفاصلة " ," بفاصلة منقوطة "; " (حسب اعدادات الجهاز عندك) لتبدو المعادلة بهذا الشكل =IF(COUNTA($C2:$D2)=0;"";SUM($C2;-$D2)+SUM($E1))

جرب هذا الملف My_date.xlsm

استبدل الفاصلة " ," بفاصلة منقوطة "; " (حسب اعدادات الجهاز عندك) لتبدو المعادلة بهذا الشكل =INT(A1)+INT((MOD(A1;1)+0.01)*100)/100

ارفع صورة للخطأ

تصحيح المعادلة كي لا يفلت اي رقم =INT(A1)+INT((MOD(A1,1)+0.01)*100)/100

كيف يمكن تحديد النصف الأول او الثاني من الشهر وأنت تدرج خلية لاول الشهر والثانية لنهايته

ربما كان المطلوب Select_Month.xls

في هذا الملف يوجد ما طلبته بالضبط حول الرقام 2.4841 >>>>> 2.49 25.36457 >>>>> 25.37 87.324 >>>>> 87.33 24.6359 >>>>> 24.64 85.5635 >>>>> 58.56 المعادلة =ROUND(A1,2)+IF(MID(ROUND(A1,2),FIND(".",A1)+1,2)+0<50,0.01,0) CREASY_ROUND.xlsx

بصراحة انا لم افهم ماذا تريد بالضبط ارجو وضع صورة بالنتائج المتوقعة(يدوياً) ولا تأخذ ارقاماً بالآلاف (فقط ارقام بسيطة من 1 حتى 20) حتى نعرف مسار المعادلات

استبدل الفاصلة " ," بفاصلة منقوطة "; " (حسب اعدادات الجهاز عندك) لتبدو المعادلة بهذا الشكل =IF(C9="";"";SUM($C$9:$C9)-SUM($D$9:$D9))