سليم حاصبيا

اخي مهند لا شيء مستحيل مع برنامج اكسل هذه المعادلة في C5 واسحب نزولاً (يمكن تغير الرقم 7 الى ما تريد والنقطة الى ما تريد ايضاً مثلا * داخل الدالة REPT) =REPT(".",7)&VLOOKUP($I$1,ورقة1!$B$6:$E$27,ROWS($C$5:C5)+1,0)&REPT(".",7) الملف مرفق New_Book.xlsx

عندها يجب استبدال الكود الى هذا Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range) Dim x%, First As Range, y%, My_address$, Answer As Byte Application.EnableEvents = False If Not Intersect(sh.Columns(1), Target) Is Nothing Then Set First = Cells(Target.Row, 1) y = Application.CountIf(ActiveSheet.Columns(1), First) If y > 1 Then My_address = ActiveSheet.Columns(1).Find(First, lookat:=1).Address Answer = MsgBox("Error!" & Chr(10) & "This Record is Allready Exits in" & Chr(10) & _ " This Sheet cell:" & My_address & Chr(10) & "do you want to continue", vbYesNo) If Answer <> 6 Then Target = vbNullString GoTo Exit_me Else GoTo Exit_me End If End If For Each sh In Sheets If sh.Name = ActiveSheet.Name Then GoTo My_next: x = Application.CountIf(sh.Columns(1), First) If x > 0 Then My_address = sh.Columns(1).Find(First, lookat:=1).Address Answer = MsgBox("Error!" & Chr(10) & "This Record is Allready Exits in" & _ Chr(10) & sh.Name & ":" & My_address & Chr(10) & _ "do you want to continue", vbYesNo) If Answer <> 6 Then Target = vbNullString GoTo Exit_me End If GoTo Exit_me End If My_next: Next End If Exit_me: Application.EnableEvents = True End Sub الملف من جديد No Repeat In All Sheets_by_choise.xlsm

ممكن نجربة هذا الكود اذا لم يكن هناك صفحة بأي اسم يقوم الماكرو باضافة صفحة جديدة بهذا الاسم و ينقل البيانات اليها Option Explicit Sub Add_sheet() Dim myname As Worksheet Dim P As Worksheet Dim sh_n%, k%, i% Set P = Sheets("اليوميه") sh_n = Application.CountA(P.Range("B:B")) - 1 Dim x%, t%: t = 2 Dim mn$ Application.ScreenUpdating = False ''''''''''''''''''''''''''''''''''''''''' For i = 2 To sh_n On Error Resume Next mn = Sheets(P.Range("b" & i) & "").Name x = Len(mn) If x = 0 Then P.Copy after:=Sheets(Sheets.Count) With ActiveSheet .Name = P.Range("b" & i) .Range("G14") = P.Range("F" & i) .Range("a1").CurrentRegion.Offset(1).ClearContents .Range("A:A").NumberFormat = ("dd- mm-yyy") For k = 2 To sh_n + 1 If P.Range("b" & k) = ActiveSheet.Name Then ActiveSheet.Cells(t, 1).Resize(, 4).Value = _ P.Range("A" & k).Resize(, 4).Value t = t + 1 End If Next End With '========================================= Else Set myname = Sheets(P.Range("b" & i) & "") myname.Range("a1").CurrentRegion.Offset(1).ClearContents For k = 2 To sh_n + 1 If P.Range("b" & k) = myname.Name Then myname.Cells(t, 1).Resize(, 4).Value = _ P.Range("A" & k).Resize(, 4).Value t = t + 1 End If Next '''''''''''''''''''''''''''''''''''' End If mn = "" Err.Number = 0 t = 2 Next i P.Select Application.ScreenUpdating = True End Sub الملف مرفق tarhil_by_names.xlsm

جرب هذا الماكرو ( اذا كان هناك تكرار تصدر رسالة بمكان التكرار و يقوم الماكرو بمسح ما كتبته) Option Explicit Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range) Dim x%, First As Range, y%, My_address$ Application.EnableEvents = False If Not Intersect(sh.Columns(1), Target) Is Nothing Then Set First = Cells(Target.Row, 1) y = Application.CountIf(ActiveSheet.Columns(1), First) If y > 1 Then MsgBox "Error!" & Chr(10) & "This Record is Allready Exits in" & Chr(10) & _ ActiveSheet.Name Target = vbNullString GoTo Exit_me End If For Each sh In Sheets If sh.Name = ActiveSheet.Name Then GoTo My_next: x = Application.CountIf(sh.Columns(1), First) If x > 0 Then My_address = sh.Columns(1).Find(First, lookat:=1).Address MsgBox "Error!" & Chr(10) & "This Record Is Already Exits in" & Chr(10) & _ sh.Name & ":" & My_address Target = vbNullString GoTo Exit_me End If My_next: Next End If Exit_me: Application.EnableEvents = True End Sub الملف مرفق No Repeat In All Sheets.xlsm

لو فرضنا ان الرقم في الخلية A1 استعمل هذه الدالة =CEILING(A1,10)

جرب هذا الماكرو Option Explicit Sub ABSCENT() Application.Calculation = xlCalculationManual Dim K As Worksheet, A As Worksheet Dim Ro_K%, col%, Ro_A%, i%, m%, t%: t = 1 Dim ALL$, ALPHA$, Str$: Str = "غ" ALL$ = " ": ALPHA = " " Set K = Sheets("keab"): Set A = Sheets("arhkeab") Ro_K = K.Cells(Rows.Count, 2).End(3).Row If Ro_K < 5 Then Exit Sub Ro_A = A.Cells(Rows.Count, 2).End(3).Row m = IIf(Ro_A < 5, 5, Ro_A + 2) For i = 5 To Ro_K If Application.CountIf(K.Cells(i, 6).Resize(1, 31), Str) = 0 Then _ GoTo My_next A.Cells(m, 2).Resize(, 2).Value = _ K.Cells(i, 2).Resize(, 2).Value For col = 6 To 36 If K.Cells(i, col) = Str Then ALL = ALL & Day(K.Cells(4, col)) & "-" ALPHA = ALPHA & K.Cells(3, col) & "-" t = t + 1 End If Next col If t > 1 Then With A.Cells(m, 4) .Value = Mid(ALL, 1, Len(ALL) - 1) .Offset(, 1) = Mid(ALPHA, 1, Len(ALPHA) - 1) .Offset(, 2) = t - 1 .Offset(, 3) = K.Cells(2, "Q") .Offset(, 4) = Year(Date) End With m = m + 1 End If My_next: t = 1 ALL = " ": ALPHA = " " Next i Application.Calculation = xlCalculationAutomatic End Sub الملف مرفق Tarhil_3iyab.xlsm

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

هذه المغادلة =CHOOSE((COUNTIF($F$1:$F$285,$K$6)<>0)+1,FALSE,TRUE)

العامود D اجعله فارغاً من كل شيء نفذذ هذا الماكرو Sub tarheel22() Dim myrange1 As Range Set myrange1 = Sheets("Sheet1").Range("E3:G4") Sheets("Sheet1").Range("a3").CurrentRegion.Clear Sheets("Mydata").Range("A3:C500").AdvancedFilter _ xlFilterCopy, myrange1, Sheets("Sheet1").[a3] End Sub الملف مرفق Salim_222.xlsb

حرب هذا الماكرو Option Explicit Sub get_my_studiants() Application.ScreenUpdating = False Dim A As Worksheet Dim B As Worksheet Set A = Sheets("ALL_STD") Set B = Sheets("B") Dim col%, r, x, LB LB = B.Cells(Rows.Count, "B").End(3).Row If LB < 5 Then LB = 5 B.Range("a5").Resize(LB - 4, 6).Clear Dim my_clas$: my_clas = B.Range("e2") Dim my_mad$: my_mad = B.Range("K2").Value If my_clas = "" Or my_mad = "" Then GoTo Exit_Sub col = A.Rows(1).Find(my_clas, lookat:=1).Column r = A.Columns(1).Find(my_mad, lookat:=1).Row x = Application.CountIf(A.Columns(1), my_mad) B.Range("b5").Resize(x).Value = _ A.Cells(r, 2).Resize(x).Value B.Range("c5").Resize(x, 3).Value = _ A.Cells(r, col).Resize(x, 3).Value With B.Range("A5").Resize(LB - 4, 6) .Columns(1).Formula = "=if(B5="""","""",max($A$4:a4)+1)" .Columns(1).Interior.ColorIndex = 6 .Borders.LineStyle = 1 .Columns(6).Formula = "=RANK(E5,$E$5:$E$29,0)+COUNTIF($E5:E$5,E5)" .Value = .Value .Font.Size = 26 .Font.Bold = True .InsertIndent 1 End With Exit_Sub: Application.ScreenUpdating = True End Sub الملف مرفق My_students.xlsm

نظام الهاتف هو Android يختلف عن نظام Windows ) لذلك لا يمكن لنظام الهاتف ان يقرأ الكود

يمكن ان ينال اعجابكم هذا الملف ايضاً ممكن توسيع نطاق الاسماء (العمودين C و D ) والعلامات حتى 250 اسماً ,ولك حرية اختيار عدد الطلاب الأوائل من الخلية L2 Order_by_notes.xlsm

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

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

جرب هذا الكود (حدد البوكس ثم انتقل الى اي خلية او اضغط Enter) Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) tesl End Sub '+++++++++++++++++++++++++++++ Sub tesl() Dim cb As CheckBox, n For Each cb In Me.CheckBoxes cb.TopLeftCell.Offset(1, -1).NumberFormat = _ IIf(cb.Value <> 1, ";;;", "General") Next cb End Sub الملف مرفق( شيت Key) TEST_xxx (3).xlsm

ارفع نموذجاّ بالبيانات كما هي و كيف تريدها(يدوياً)

بعد اذن اخي حسن مأمون بواسطة هذا الكود تستطيع اختصار 94 حلقة تكرارية (y=6 to 100) في كل دورة من الـــ X من 1 الى Lr اذن لوكان عدد الصفوف 100 صف فاننا نقوم بــ 94×100= 9400 حلقة تكرارية لا حاجه لها يمكن هنا استعمال الدالة Match او الدالة Find لتحديد العامود الذي نريد الصاق قيمة الخلية المطلوب ولا حاجة للدورة ثانية من الحلقات التكراية(y) كما لا ننسى تفريغ النطاق كله قبل مباشرة الكود بالعمل من خلال السطر السادس من الكود وبذلك نوفر الجهد و عدم حشو الذاكرة بشيء لاتستفيد منه اضافة الى تحجيم الملف هذا مثال عن الماكرو كما اتصوره هنا Sub MY_code() Dim x%, lr%, col%, Last_col% Dim Find_cel As Range Last_col = Cells(2, Columns.Count).End(1).Column lr = Cells(Rows.Count, "e").End(3).Row Range("F3").Resize(lr, Last_col - 5).Clear For x = 3 To lr Set Find_cel = Rows(2).Find(Cells(x, "e"), lookat:=1) If Not Find_cel Is Nothing Then col = Find_cel.Column Cells(x, col) = Cells(x, "D") End If Next With Range("F3").Resize(lr, Last_col - 5).SpecialCells(2) .Borders.LineStyle = 1 .Interior.ColorIndex = 6 .Font.Bold = True .HorizontalAlignment = 3 End With End Sub الملف مرفق My_value.xlsm

الصف غير الفارغ يجب ان تكون جميع خلاياه غير فارغة

لا تنس اننا نتعامل مع القروش (كما انت ذكرت في المشاركة) 2) اثنى عشر قرشا في السنة عما يجاوز العشرة ألاف اذن 1 جنيه يساوي 100 قرش

تم التعديل على الماكرو Function how_to_pay(Myfact As Long, n1 As Long, n2 As Long, n3 As Long) As Long Select Case Myfact Case Is <= 10000 How_Many = Myfact * n1 ' a Case Is <= 500000 How_Many = (10000 * n1) + (Myfact - 10000) * n2 ' a+b Case Is > 500 How_Many = (10000 * n1) + (50000 * n2) + (Myfact - 50000) * n3 'a+c+d+e End Select how_to_pay = How_Many End Function '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- Sub verifay_count() Dim M As Long, i%, X As Long With Sheets("Sheet1").Range("C3", Range("C2").End(4)) For i = 1 To .Rows.Count M = how_to_pay(.Cells(i), Range("k2"), Range("L2"), Range("M2")) / 1000 Select Case M Case Is < 100: X = 100 Case Is > .Cells(i).Offset(, 1) * 12 * 0.05 Select Case .Cells(i).Offset(, 1) * 12 * 0.05 Case Is < M: X = .Cells(i).Offset(, 1) * 12 * 0.05 Case Else: X = M End Select M = .Cells(i).Offset(, 1) * 12 * 0.05 End Select .Cells(i).Offset(, 2) = X Next End With End Sub الملف مرفق Facture_1.xlsm

قم بانشاء شيت جديد باسم Salim ونفذ هذا الكود Option Explicit Sub Del_Exta_Rows() Dim S_sh As Worksheet 'source sheet Dim T_sh As Worksheet 'target sheet Dim Lrs% 'laste row in source sheet Dim Cols% 'laste column in source sheet Set S_sh = Sheets("Recovered_Sheet1") Set T_sh = Sheets("Salim") T_sh.Cells.Clear Lrs = S_sh.Cells(Rows.Count, 1).End(3).Row Cols = S_sh.Cells(1, Columns.Count).End(1).Column S_sh.Cells(1, 1).Resize(Lrs, Cols). _ SpecialCells(xlCellTypeConstants).Copy T_sh.Cells(1, 1).PasteSpecial (xlPasteAll) Application.CutCopyMode = False With T_sh.Range("a1").CurrentRegion .Columns.AutoFit .Borders.LineStyle = 1 .Cells(1).Select End With End Sub الملف مرفق ( شيت Salim ) DEL_ROWS.xlsm

استعمل هذه الدالة Function how_to_pay(Myfact As Long, n1 As Long, n2 As Long, n3 As Long) As Long '''''''''''''''''''''''''''''''''''''''''' Select Case Myfact Case Is <= 10000 How_Many = Myfact * n1 ' a Case Is <= 500000 How_Many = (10000 * n1) + (Myfact - 10000) * n2 ' a+b Case Is > 500 How_Many = (10000 * n1) + (50000 * n2) + (Myfact - 50000) * n3 'a+c+d+e End Select how_to_pay = How_Many '''''''''''''''''''''''''''''''''''''''' End Function الملف مرفق للتوضيح Facture.xlsm

بعد تنفيذ الماكرو الق نظرة على الشيتات ترى كل شيء قد تم كما تريد

ممكن ان يكون الحل هنا ايضاً three_cond_format.xlsx

تمت معالجة الامر Option Explicit Sub MY_Data_New() Application.ScreenUpdating = False Dim SH_from As Worksheet Dim T As Worksheet Dim rg_to_Patse As Range Dim Rt%, MY_max%, ro%: ro = 4 Set T = Sheets("Total") Set rg_to_Patse = T.Range("A3").CurrentRegion Rt = rg_to_Patse.Rows.Count If Rt > 1 Then Set rg_to_Patse = rg_to_Patse.Offset(1).Resize(Rt - 1) Else Set rg_to_Patse = T.Range("B4").Resize(, 5) End If rg_to_Patse.Clear For Each SH_from In Sheets If SH_from.Name <> T.Name Then MY_max = Application.Max(SH_from.Range("A:A")) SH_from.Cells(3, 1).Resize(MY_max, 6).Copy With T.Cells(ro, 1) .PasteSpecial (xlPasteValues) .PasteSpecial (xlPasteFormats) End With ro = ro + MY_max End If Next SH_from With T.Range("A3").Resize(ro - 4, 6) .Sort key1:=Range("b3"), Header:=1 End With Application.ScreenUpdating = True arraNge_all End Sub '+++++++++++++++++++++++++++++++++++ Sub arraNge_all() Application.ScreenUpdating = False Dim nro% Dim MM% nro = Cells(Rows.Count, 1).End(3).Row Dim color_rg As Range For MM = 4 To nro If Range("B" & MM).Interior.ColorIndex = 2 Or _ Range("B" & MM).Interior.ColorIndex = -4142 Then GoTo Next_MM If color_rg Is Nothing Then Set color_rg = Range("B" & MM).Resize(, 5) Else Set color_rg = Union(color_rg, Range("B" & MM).Resize(, 5)) End If Next_MM: Next If color_rg Is Nothing Then GoTo Contenu color_rg.Copy Range("B" & nro + 1) color_rg.EntireRow.Delete Contenu: Range("B4", Range("B3").End(4)).Offset(, -1).Formula = _ "=IF(B4="""","""",MAX($A$3:A3)+1)" With Range("A3").CurrentRegion .Value = .Value .Borders.LineStyle = 1 End With Range("A4").Select Set color_rg = Nothing create_borders Application.ScreenUpdating = True End Sub '+++++++++++++++++++++++++++++++++++ Sub create_borders() Dim My_sh As Worksheet, r For Each My_sh In Sheets If My_sh.Name <> "Total" Then r = My_sh.Cells(Rows.Count, 2).End(3).Row My_sh.Cells.Borders.LineStyle = xlNone My_sh.Range("a2").Resize(r - 1, 6).Borders.LineStyle = 1 End If Next End Sub الملف الأخير Laste_flie.xlsm