سليم حاصبيا

تم تحرير كود لهذا الغرض 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("A4").Resize(ro - 4, 6) .Sort key1:=Range("b3"), Header:=1 .Value = .Value 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("a" & MM).Interior.ColorIndex <> xlNo Then If color_rg Is Nothing Then Set color_rg = Range("a" & MM).Resize(, 6) Else Set color_rg = Union(color_rg, Range("a" & MM).Resize(, 6)) End If End If Next color_rg.Copy Range("a" & nro + 1) color_rg.EntireRow.Delete Range("A4", Range("A3").End(4)).Formula = _ "=IF(B4="""","""",MAX($A$3:A3)+1)" Range("A3").CurrentRegion.Value = _ Range("A3").CurrentRegion.Value Range("A4").Select Set color_rg = Nothing Application.ScreenUpdating = True End Sub الملف من جديد M_data_new_SA.xlsm

تم معالجة الامر ملاحظة يجب ترك الصف 2 في الشيت total فارغاً للحفاظ على بنية الجدول دون تدخل خلايا غريبة (بذلك تكون اول خلية بالجدول بعد الرأس هي الخلية A4) Option Explicit Sub get_data_New() 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")) T.Cells(Ro, 2).Resize(MY_max, 5).Value = _ SH_from.Cells(3, 2).Resize(MY_max, 5).Value Ro = Ro + MY_max End If Next SH_from With T.Range("A3").CurrentRegion .Sort key1:=Range("b3"), Header:=1 .Columns(1).Offset(1).Formula = _ "=IF(B4="""","""",MAX($A$3:A3)+1)" .Offset(1).Borders.LineStyle = 1 .Offset(1).InsertIndent 1 .Value = .Value .Font.Bold = True End With End Sub M_data_new.xlsm

قم بتغيير اسم الشيت مجمل إلى Total ونفذ هذا الكود Option Explicit Sub get_data() Dim SH_from As Worksheet Dim T As Worksheet Dim Rt%, MY_max%, Ro%: Ro = 3 Set T = Sheets("Total") Rt = T.Cells(Rows.Count, 2).End(3).Row If Rt <= 2 Then Rt = 3 With T.Range("B3").Resize(Rt, 5) .ClearContents .Interior.ColorIndex = xlNo End With For Each SH_from In Sheets If SH_from.Name <> T.Name Then MY_max = Application.Max(SH_from.Range("A:A")) T.Cells(Ro, 2).Resize(MY_max, 5).Value = _ SH_from.Cells(3, 2).Resize(MY_max, 5).Value With T.Cells(Ro + MY_max, 3) .Value = SH_from.Name .Offset(, -1).Resize(, 5).Interior.ColorIndex = 6 End With Ro = Ro + MY_max + 1 End If Next SH_from End Sub الملف مرفق M_data.xlsm

المعادلة لا تستطيع ان تدرج اي تعليق او ان تقوم بتنسيق اي خلية او تغيير لونها... (هذا ليس من عمل المعادلات) فأنت لا تستطيع ان تقول للمعادلة اجعلي لي لون الخلية الفلانية احمر مثلاً حتى تستطيع MicroSoft ابتكار هكذا معادلات ما علينا سوى الصبر والانتظار أو عمل ذلك بواسطة الـــ vba

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

تم التعديل على الملف المعادلات تعتمد على الجدول الأصفر CARES.xlsx

جرب هذا المعادلة في الحلية Q2 واسحب نزولاً هذا اذا كنت قد فهمت عليك ماذا تريد =VLOOKUP(O3,{0,0;30,1;60,2},2)*30

جرب هذا الكود Option Explicit Sub TEST() Dim myvalu$, lr%, x1$, x2$ x1 = """" & Me.TextBox1 & """": x2 = """" & Me.TextBox2 & """" lr = Cells(Rows.Count, 1).End(3).Row myvalu = "=SUMPRODUCT((O6:O" & lr & "=" & x1 & ")*(P6:P" & lr & "=" & x2 & "))" 'for hide the formula Cells(1, "N") = Evaluate(myvalu) 'Or for show the formula Cells(2, "N").Formula = myvalu End Sub

شاهد هذا لفيديو https://www.youtube.com/watch?v=hElkHVLg7a4

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

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

مع اني افضل هذا الكود لأنه لا ضرورة للضغط على OK في كل مرة تظهر رسالة التنبيه Private Sub CommandButton1_Click() Dim Final_row As Long, k% Final_row = Cells(Rows.Count, 1).End(3).row + 1 For k = 1 To 5 Cells(Final_row, 1).Offset(, k - 1) = Me.Controls("TextBox" & k) Next On Error GoTo EXIT_ME Cells(Final_row, 1) = CInt(Cells(Final_row, 1)) colorize_me For k = 1 To 5 Me.Controls("TextBox" & k) = vbNullString Next Exit Sub EXIT_ME: MsgBox "YOU MUST ENTER A NUMBER>0" Cells(Final_row, 1).Resize(, 5).ClearContents For k = 1 To 5 Me.Controls("TextBox" & k) = vbNullString Next End Sub '++++++++++++++++++++++++++++++++++++++ Sub colorize_me() Dim laste_row As Long, I As Long laste_row = Cells(Rows.Count, 1).End(3).row Range("A8").Resize(laste_row - 7, 7).Interior.ColorIndex = xlNon myvalu = "=SUMPRODUCT(--(A8" & "&" & """*""" & "&" & _ "B8=$A$8:A" & 8 & "&" & """*""" & "&" & "B$8:B" & 8 & "))" Range("MM8").Resize(laste_row - 7).Formula = myvalu Range("g8").Resize(laste_row - 7).ClearContents For I = 8 To laste_row If Range("MM" & I) > 1 Then Range("A" & I).Resize(, 5).Interior.ColorIndex = 6 Range("A" & I).Offset(, 6) = "Duplicate: " & _ Range("MM" & I) - 1 & IIf(Range("MM" & I) = 2, "Time", "Times") Range("A" & I).Offset(, 6).Interior.ColorIndex = 3 End If Next Range("MM8").Resize(laste_row - 7).Clear End Sub الملف SALIM_code_UPDATED(1).xlsm

تم التعديل على الماكرو Private Sub CommandButton1_Click() Dim Final_row As Long, k% Final_row = Cells(Rows.Count, 1).End(3).row + 1 For k = 1 To 5 Cells(Final_row, 1).Offset(, k - 1) = Me.Controls("TextBox" & k) Next On Error GoTo EXIT_ME Cells(Final_row, 1) = CInt(Cells(Final_row, 1)) colorize_me For k = 1 To 5 Me.Controls("TextBox" & k) = vbNullString Next Exit Sub EXIT_ME: MsgBox "YOU MUST ENTER A NUMBER>0" Cells(Final_row, 1).Resize(, 5).ClearContents For k = 1 To 5 Me.Controls("TextBox" & k) = vbNullString Next End Sub '++++++++++++++++++++++++++++++++++++++ Sub colorize_me() Dim laste_row As Long, I As Long laste_row = Cells(Rows.Count, 1).End(3).row Range("A8").Resize(laste_row - 7, 5).Interior.ColorIndex = xlNon myvalu = "=SUMPRODUCT(--(A8" & "&" & """*""" & "&" & _ "B8=$A$8:A" & 8 & "&" & """*""" & "&" & "B$8:B" & 8 & "))" Range("MM8").Resize(laste_row - 7).Formula = myvalu For I = 8 To laste_row If Range("MM" & I) > 1 Then Range("A" & I).Resize(, 5).Interior.ColorIndex = 6 MsgBox "Duplicate: " & Chr(10) & Range("MM" & I) - 1 & IIf(Range("MM" & I) = 2, "Time", "Times") End If Next Range("MM8").Resize(laste_row - 7).Clear End Sub الملف من جديد SALIM_code_UPDATED.xlsm

جرب هذا الكود Option Explicit Sub find_medicament() Dim Rep As Worksheet Dim sh As Worksheet Dim Med_Name$ Dim r, m%: m = 6 Set Rep = Sheets("Repport") Rep.Range("a6:H25").ClearContents If Rep.Range("H5") = vbNullString Then Exit Sub Med_Name = Rep.Range("H5") For Each sh In Sheets If sh.Name <> Rep.Name Then If sh.Range("B:B").Find(Med_Name, lookat:=1) Is Nothing Then GoTo next_sh r = sh.Range("B:B").Find(Med_Name, lookat:=1).Row With Rep .Cells(m, 1) = sh.Name .Cells(m, 2) = sh.Range("A4") .Cells(m, 3) = sh.Range("D4") .Cells(m, 4) = sh.Range("F" & r) .Cells(m, 6) = sh.Range("G" & r) m = m + 1 End With End If next_sh: Next End Sub '+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= Sub fil_dataval() Dim Rep As Worksheet Dim sh As Worksheet, my_rg As Range Dim dic As Object Dim i%: i = 6 Set Rep = Sheets("Repport") Set dic = CreateObject("Scripting.dictionary") For Each sh In Sheets i = 6 If sh.Name <> Rep.Name Then Do Until sh.Range("b" & i) = vbNullString dic(sh.Range("b" & i).Value) = "" i = i + 1 Loop End If Next With Rep.Range("H5").Validation .Delete .Add 3, Formula1:=Join(dic.keys, ",") End With End Sub الملف مرفق Hospital_sal.xlsm

تم معالجة الامر Option Explicit Sub Edit_data() Dim Source_rg As Range Dim Find_rg As Range Dim r# Range("B8:M8").ClearContents Range("B4:M4").ClearContents Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row Set Source_rg = Me.Range("a12:M" & lra) Set Find_rg = Source_rg.Columns(2).Find(Me.Range("D6"), Lookat:=1) If Find_rg Is Nothing Then MsgBox "'This Number Does't Exists" Exit Sub End If r = Find_rg.Row With Me.Range("B8") .Value = Cells(r, 2): .Offset(, 1) = Cells(r, 3): .Offset(, 2) = Cells(r, 4) .Offset(, 3) = Cells(r, 5): .Offset(, 4) = Cells(r, 6): .Offset(, 5) = Cells(r, 7) .Offset(, 6) = Cells(r, 8): .Offset(, 7) = Cells(r, 9): .Offset(, 8) = Cells(r, 10) .Offset(, 9) = Cells(r, 11): .Offset(, 10) = Cells(r, 12) .Offset(, 11) = Cells(r, 13) End With End Sub '+++++++++++++++++++++++++++++++++++++++++++ Sub ADD_data() Dim Source_rg As Range Dim Find_rg As Range Dim r# Dim lra#: lra = Me.Cells(Rows.Count, 2).End(3).Row + 1 Set Source_rg = Me.Range("a12:M" & lra) If Me.Range("d2") = "" Then MsgBox "NO data to Enter": Exit Sub Set Find_rg = Source_rg.Find(Me.Range("d2"), Lookat:=1) If Not Find_rg Is Nothing Then MsgBox "This activity is exits": Exit Sub Range("B4:M4").Copy Cells(lra, 2).PasteSpecial (xlPasteValues) Application.CutCopyMode = False: Me.Range("d2").Select End Sub '++++++++++++++++++++++++++++++++++++++++++++++++ Sub Ta3dil() Dim Source_rg As Range Dim Find_rg As Range Dim r# Dim lra#: lra = Me.Cells(Rows.Count, 2).End(3).Row Set Source_rg = Me.Range("a12:M" & lra) Set Find_rg = Source_rg.Columns(2).Find(Me.Range("D2"), Lookat:=1) If Not Find_rg Is Nothing Then MsgBox "This activity is exits": Exit Sub Range("B4:M4").Copy Cells(lra + 1, 2).PasteSpecial (xlPasteValues) Application.CutCopyMode = False: Me.Range("d2").Select End Sub T-2019_Salim_UPDATE.xlsm

لا أعلم اذا كان هذا المطلوب Leave_book.xlsx

اختصار للأكواد (يمكنك التعامل مع الشيت حتى ولو كان اليوزر ظاهراً) Private Sub CommandButton1_Click() Sheets(1).Activate lrow = Range("a" & Rows.Count).End(xlUp).Row For k = 1 To 5 With Range("a" & lrow + 1) .Offset(, k - 1).Value = Me.Controls("TextBox" & k) Me.Controls("TextBox" & k) = vbNullString End With Next MsgBox "New Record Has Added in Row :" & lrow + 1 TextBox1.Value = lrow + 2 TextBox2.SetFocus End Sub '=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= Private Sub UserForm_Initialize() Me.ListBox1.ColumnCount = 6 Srow = Range("a" & Rows.Count).End(xlUp).Row Me.ListBox1.RowSource = Range("a2:f" & Srow).Address TextBox1.Value = Srow + 1 TextBox2.SetFocus End Sub الملف مرفق MY_User.xlsm

يلزم هذين الكودين من اجل اليوزر (يمكنك العمل على الشيت حتى ولو كان اليوزر ظاهراً) بعد الضغط على الزر اضافة السجل 1- تنقل كل البينات الى مواقعها 2 - يتم تلوين المكرر 3- تمسح البيانات من اليوزر بانتظار البيانات الجديدة Private Sub CommandButton1_Click() Dim Final_row As Long, k% Final_row = cells(rows.Count, 1).End(3).row + 1 For k = 1 To 5 cells(Final_row, 1).Offset(, k - 1) = Me.Controls("TextBox" & k) Next colorize_me For k = 1 To 5 Me.Controls("TextBox" & k) = vbNullString Next End Sub '++++++++++++++++++++++++++++++++++++++ Sub colorize_me() Dim laste_row As Long, I As Long laste_row = cells(rows.Count, 1).End(3).row Range("A8").Resize(laste_row - 7, 5).Interior.ColorIndex = xlNon myvalu = "=SUMPRODUCT(--(A8" & "&" & """*""" & "&" & _ "B8=$A$8:A" & TextBox1 & "&" & """*""" & "&" & "B$8:B" & TextBox1 & "))" Range("MM8").Resize(laste_row - 7).Formula = myvalu For I = 8 To laste_row If Range("MM" & I) > 1 Then _ Range("A" & I).Resize(, 5).Interior.ColorIndex = 6 Next Range("MM8").Resize(laste_row - 7).Clear End Sub الملف مرفق SALIM_code.xlsm

تم معالجة الامر Max_min_special.xlsx

الملف جاهز مجرد ان تحدد ما المطلوب من الخلية A3 ستجد كل شيء امامك My_data.xlsm

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

بعد اذن الاخ علي نظرة على هذا الملف Max_min.xlsx

اين الاستبانة؟؟؟؟

لا لزوم للكود ولا لليوزر في هذه الحالة شاهد هذا الملف COND_FORMAT.xlsm

هذه الاشياء يمكنك كتابتها يدوياً لمرة واحدة فقط