سليم حاصبيا

تم التعديل على الملف Cond_form_1.xlsx

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

ربما هذا المطلوب Cond_form.xlsx

تم وضع ملف جدبد بحتوي على 2 يوزر (يعملان على كل الصفحات) بالضغط على الزر المناسب الازرار موجودة في كل الصفخات 1- اليوزر القديم الذي ارسلته لك في مشاركة سابقة للبحث والتعديل و الجذف والاضافة 2- User جديد يمكن من خلاله البحث عن اي اسم من خلال كتابة الحروف الاولى من الاسم ( جرف أو 2 او 3 او فدر ما نريد ) فيTextBox الأصفر ثم الضغط على Enter تطهر لك في ال ListBox كل الاسماء التي تبدأ بهذه الجروف مع بياناتها تحتار الاسم الذي تربد من حلال الضغط عليه في ListBox فتظهر بياناته في TextBoxes كلها الملف مرفق toukilat 2 Users.xlsm

الخلايا المدمجة ممنوعة لأن الكود الذي سوف يتم وضعه يأخذ أول خلية من النطاف المدمج بالنسبة للأعمدة الباقية الصورة توضح ذلك ايمان تأخذ الرقم 5795 الحرف ج والتاريخ 16/10/2016 اما الباقين اسراء و مشترك مع خرف ع لا يأخذون شيئاً

صديقى انا وضعت لك كود (جسب طلبك) ولست مسؤولاً عن ما يضعه الغير ان كان صحيحاً ام لا

تم حل المطلوب (الأزرار اضافة حذف بحث و تعديل ) الزر حفظ لا حاجة له زر الحذف لا يعمل (يتم تعطيله عند فتح اليوزر و بواسطة CheckBox يمكن اعادة تشغيله) الا اذا كان الــــ CheckBox الذي يحتوي على عبارة (Make True for Del) مفعلاً لعدم التسّرع بالحذف اذ يجب تغعيل زر الحذف اولاً بعد كل عملية حذف يتم تعطيل الزر لضمان عدم النقر علية اكثر من مرة (بواسطة CheckBox يمكن اعادة تشغيله) Toukilat_1.xlsm

ارفع الملف نفسه لا يمكن التعامل مع صورة

حيث أنك لم ترقع ملف للمعاينة جرب هذا الملف Fuction_split_name.xlsm

تم التعديل كما تريدين الأعداد السالبة تظهر باللون الأصفر والموجبة بالأخضر(شرط تطابق التاريخ) حلايا التاريخ المطلوب باللون الزهري Option Explicit Sub get_special_columns() Dim D As Worksheet Dim Sh As Worksheet Dim Ar(), Min_date As Date, Max_date As Date Dim K%, t%, Arr_sh() Dim My_ro%, m%, ro%, my_sum#, x% Dim Sum_pos#, Sum_Neg# K = 2 Set D = Sheets("DataReport") D.Rows.Hidden = False If D.Range("A3").CurrentRegion.Rows.Count > 1 Then D.Range("A3").CurrentRegion.Offset(1). _ Resize(D.Range("A3").CurrentRegion.Rows.Count - 1).Clear End If If Not IsDate(D.Range("J2")) Or _ Not IsDate(D.Range("K2")) Then Exit Sub Min_date = Application.Min(D.Range("J2:K2")) Max_date = Application.Max(D.Range("J2:K2")) Ar = Array("E", "F", "G", "H", "I", "J") For Each Sh In Sheets If Sh.Tab.ColorIndex = D.Range("N1") Then ReDim Preserve Arr_sh(m) Arr_sh(m) = Sh.Name: m = m + 1 End If Next Sh If m = 0 Then Exit Sub For m = LBound(Arr_sh) To UBound(Arr_sh) D.Cells(K, 1) = Arr_sh(m) D.Cells(K + 1, 1) = "Total " & D.Cells(12, "J") D.Cells(K + 1, 1).Resize(, UBound(Ar) + 2).Interior.ColorIndex = 20 K = K + 2 Next m My_ro = 3 For m = LBound(Arr_sh) To UBound(Arr_sh) Set Sh = Sheets(Arr_sh(m)) Sh.Range("A5:J20000").Interior.ColorIndex = xlNone ro = Sh.Cells(Rows.Count, 1).End(3).Row For K = LBound(Ar) To UBound(Ar) t = K + 2 For x = 5 To ro If Sh.Cells(x, 1) <= Max_date _ And Sh.Cells(x, 1) >= Min_date Then Sh.Cells(x, 1).Interior.ColorIndex = 40 If Val(Sh.Cells(x, Ar(K))) <> 0 Then my_sum = my_sum + Sh.Cells(x, Ar(K)) '+++++++++++++++++++++++++++++ If Val(Sh.Cells(x, Ar(K))) <= 0 Then Sum_Neg = Sum_Neg + Val(Sh.Cells(x, Ar(K))) Sh.Cells(x, Ar(K)).Interior.ColorIndex = 6 Else Sum_pos = Sum_pos + Val(Sh.Cells(x, Ar(K))) Sh.Cells(x, Ar(K)).Interior.ColorIndex = 35 End If '++++++++++++++++++++++++++ End If End If Next x Select Case D.Cells(12, "J") Case "Positive" D.Cells(My_ro, t) = Sum_pos Case "Nagative" D.Cells(My_ro, t) = Sum_Neg Case Else D.Cells(My_ro, t) = my_sum End Select my_sum = 0: Sum_pos = 0: Sum_Neg = 0 Next K My_ro = My_ro + 2 Next m D.Cells(My_ro, 1) = "Sum Of All" Rem D.Cells(My_ro - 1, 2).Resize(, UBound(Ar) + 1) = Ar With D.Cells(My_ro - 1, 2).Resize(, 6) .Value = D.Cells(1, 2).Resize(, 6).Value .Interior.Color = vbBlue .Font.Color = vbWhite End With D.Cells(My_ro, 2).Resize(, UBound(Ar) + 1).Formula = _ "=Sum(B3:B" & My_ro - 2 & ")" D.Cells(My_ro, 1).Resize(, UBound(Ar) + 2).Interior.ColorIndex = 6 If D.Range("A3").CurrentRegion.Rows.Count > 1 Then With D.Range("A3").CurrentRegion.Offset(1). _ Resize(D.Range("A3").CurrentRegion.Rows.Count - 1) .Borders.LineStyle = 1: .Font.Size = 14 .Font.Bold = True: .HorizontalAlignment = xlCenter .Value = .Value End With End If For m = My_ro - 2 To 3 Step -1 If D.Cells(m, 1) Like "Total*" And _ Application.Sum(D.Cells(m, 2).Resize(, 6)) = 0 Then D.Range(Cells(m, 1), Cells(m - 1, 1)).EntireRow.Hidden = True End If Next End Sub '++++++++++++++++++++++++++++++ Sub show_all() Sheets("DataReport").Rows.Hidden = False End Sub الملف مرفق Yara_Pos_Neg_All.xlsb

جب هذا الملف jack_Gardes.xlsx

تم التعديل الشيت Salim من هذا الملف Jack_Numeration_1.xlsm

Try this File Jack_Numeration.xlsm

بارك الله فيك استاذ محي الدين وهذا ماكرو اخر لنفس الهدف (زيادة في اثراء الموضوع) Option Explicit Sub Expand_Me() Dim i%, M%, y%, x As Byte M = 2 y = Sheets("Feuil1").Range("A1"). _ CurrentRegion.Rows.Count If y = 1 Then Exit Sub With Sheets("Feuil2") .Range("A1").CurrentRegion.ClearContents .Range("A1").Resize(, 14).Value = _ Sheets("Feuil1").Range("A1").Resize(, 14).Value For i = 2 To y x = Sheets("Feuil1").Range("G" & i) .Range("A" & M).Resize(x, 14).Value = _ Sheets("Feuil1").Range("A" & i).Resize(, 14).Value M = x + M Next i End With End Sub

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

اذا اردت حذف يومين تحتارهما اليك هذا الملف (صفحة Salim) date_without 2 days.xlsx

استبدل الى هذا الماكرو (عليك الانتطار قليلاً حوالي الدقيقة كي يكمل الماكرو عمله) بسبب كثرة الداتا Option Explicit Sub test() Dim Ro As Long, Rg As Range Dim x As Long, t As Long, i As Long With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With With Sheets("ورقة1") Ro = .Cells(Rows.Count, 1).End(3).Row Set Rg = .Range("A1:A" & Ro).SpecialCells(2, 23) .Range("E1").Resize(Ro, 2).Clear t = 1 For x = 1 To Rg.Areas.Count .Cells(t, "E").Resize(Rg.Areas(x).Rows.Count) = _ Rg.Areas(x).Cells(1, 1) .Cells(t, "E").Interior.ColorIndex = 6 For i = 2 To Rg.Areas(x).Rows.Count .Cells(t + 1, "F").Offset(i - 2) = _ Rg.Areas(x).Cells(i).Offset(, 2) Next i t = t + Rg.Areas(x).Rows.Count + 1 Next x With .Range("E1").Resize(Ro, 2).SpecialCells(2, 23) .Borders.LineStyle = 1 .Font.Bold = True .InsertIndent 1 End With End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق Sk_Khalige.xlsm

الورقة Card انت اردتها وانا أعرف انه لا فائدة منها الا اذا اردت ان تطبع بطاقات للتلامذة (وهذا ما كنت افكر به) لذلك تركتها البيانات في ALL_Names هي نفسها في Card (مختلفة بالشكل فقط) فما الفرق من اين تأخذ الورقة Single_Match معلوماتها

ابن هو التنسيق السابق؟؟؟؟

Essayez ce fichier Naser_date.xlsx

حل أخر في المرفق mrahmedyoussef.xlsx

تم معالجة الأمر كما تريد 1- تدرج كل الأسماء (بدون صقوف فارغة) مع البيانات التابعة لها في الشيتت ALL_Names ( ليس من الضروري كل البيانات) 2 -في الشيت Card تضغط على الزر Get The Cards 3- في الشيت Single_Match العامود (A) تختار اي رقم (أو عدة أرقام) ثم تضغط على الزر Find For_Me وذلك للجصول على بيانات منفردة عن تلميذ واحد أو اكثر اذا كان الرقم التي اخترته غير موجود في الشيت ALL_Names يبقي الصف فارغاً Haggag_New.xlsm

يمكنك استعمال هذا الماكرو لنقل الأسماء الى الجداول المحصصة لكل طالب لان عملية نسخ الجدول ولضقه اكثر من مرة ليست بالأمر السهل خاصة اذا كان عدد الطلاب كبير (50 أو اكثر) فقط اضغط على الزر Give Data في الشيت Repport و ترى كل شيء امامك الجداول والاسماء فيها (بدون معادلات) عندها تملأ الداتا الحاصة لكل تلميذ و بدورها تنتقل الى الشيت ترحيل الماكرو Option Explicit Sub copy_Range() Dim S As Worksheet Dim R As Worksheet Dim i%, k%, x Dim Rg_To_Copy Application.ScreenUpdating = False Set S = Sheets("ST_names") Set R = Sheets("Repport") Set Rg_To_Copy = R.Range("A1:D13") i = 2: k = 16 R.Range("A16").Resize(1000, 4).Clear Do Until S.Range("A" & i).Offset(1) = vbNullString Rg_To_Copy.Copy R.Range("A" & k).PasteSpecial (xlAll) R.Range("B" & k + 1).Resize(10).ClearContents R.Range("D" & k + 1).Resize(10).ClearContents With R.Range("A" & k) .Offset(1, 1) = x + 2 .Offset(2, 1) = S.Range("D" & i + 1) .Offset(1, 3) = S.Range("F" & i + 1) End With k = k + 15: x = x + 1: i = i + 1 Loop Application.CutCopyMode = False Application.ScreenUpdating = True R.Cells(2, 1).Select End Sub الملف مرفق للاطلاع وإبداء الرأي Haggag_1.xlsm

الملف الذي رفعته انت لا يشبه بأي شكل الملف الذي رفعته لك انا

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