نجوم المشاركات

الكود من أجل هذا الشيء Private Sub CommandButton1_Click() 'add Employ Set My_sh = Sheets("sheet1") RO = My_sh.Cells(Rows.Count, 1).End(3).Row + 1 Set Sarch_rg = My_sh.Range("A1:A" & RO) Set Found_rg = Sarch_rg.Find(txtcode.Text, lookat:=1) If Not Found_rg Is Nothing Then MsgBox "This Code is allready Exists" & Chr(10) & _ "In thee cell: " & Found_rg.Address(0, 0), 64 Exit Sub Else With My_sh.Cells(RO, 1) .Value = Me.txtcode.Value .Offset(, 1) = Me.txtname.Value .Offset(, 2) = Me.txtjop.Value .Offset(, 3) = Me.txtadress.Value .Offset(, 4) = Me.txtid.Value End With End If Me.ListBox1.RowSource = "a2:e" & RO End Sub

وعليكم السلام-عليك بإستبدال معادلتك بهذه المعادلة =IFERROR(INDEX($A$2:$A$200,SMALL(IF($D$2:$D$200=$G$2,IF($E$2:$E$200=$H$2,ROW(A$2:A$200)-ROW(A$2)+1)),ROWS($H$5:H5))),"") 1قوائم.xlsx

تفضل Sub Test() ActiveSheet.UsedRange.EntireColumn.AutoFit ActiveSheet.UsedRange.EntireRow.AutoFit End Sub أو يمكنك استخدام هذا الكود أيضاً Option Explicit Sub Auto_Fit() Dim sh As Worksheet For Each sh In ThisWorkbook.Worksheets sh.Columns.AutoFit sh.Rows.AutoFit Next sh End Sub مثال.xlsm

كود لأرجاع كل شيء كما كان Option Explicit Sub UNMERG() Dim x%, y%, Cel As Range With Range("A1").CurrentRegion For Each Cel In .Cells x = Cel.MergeArea.Rows.Count y = Cel.MergeArea.Columns.Count Cel.UnMerge Cel.Resize(x, y) = Cel.Cells(1, 1).Value Next .Borders.LineStyle = 1 End With End Sub

شكر وتقدير واحترام الاستاذ الكبير سليم والاستاذ الفاضل وجيه

رائع استاذ وجيه باقي كود لأرجاع كل شيء كما كان بعد اذنك بلاش الـــ Select دي التي لا فائدة منها Sub aa() Application.DisplayAlerts = False Dim i, J As Integer For J = 1 To 16 For i = 2 To 7 If Cells(J, i) = Cells(J, i + 1) And Cells(J, i) <> "" _ And Cells(J, i + 1) <> "" Then Range(Cells(J, i), Cells(J, i + 1)).Merge End If Next Next Application.DisplayAlerts = True End Sub

بعد اذن استاذنا سليم واثراء للموضوع انظر الى هذا المرفق نسخة من دمج الخلايا عندما تكون لها نفس القيم-1.xlsm

1- اي نعديلات على الجدول يجب ادراجها في النطاق AA1:AG16 لأن الماكرو يأخذ البيانات من هناك بالنسبة للـــ UNMERGE جرب هذا الماكرو (الصفحة SALIM من هذا الملف ) Option Explicit Sub Mreg_equal_cells() Dim Ro%, i%, k%, t%, n%, ky Dim d As Object Dim Rg As Range Set d = CreateObject("Scripting.Dictionary") Ro = Cells(Rows.Count, 1).End(3).Row For t = 2 To 7 k = 1 Do Until k > Ro i = k: n = 1 Do Until Cells(i, t) <> Cells(i + 1, t) n = n + 1 i = i + 1 Loop Set Rg = Cells(k, t).Resize(n) d(Rg.Address) = "" k = k + n Loop Application.DisplayAlerts = False For Each ky In d.keys Range(ky).Merge Next Application.DisplayAlerts = True d.RemoveAll Next Application.DisplayAlerts = True End Sub '+++++++++++++++++++ Sub No_merge() Range("AA1:AG16").Copy Range("A1") End Sub الملف مرفق الصفحة SALIM bachiri401_MERGE.xlsm

تفضل -يمكنك استخدام هذه المعادلة فى التنسيقات الشرطية =TRIM(MID(B6,IFERROR(FIND("رخام",B6,1)+0,1),9^9))="رخام" تلوين1.xlsx

1-لا حاجة لنكرار المتغيرات في كل كود من أكواد اليوزر يكفي ان تعلنها مرة واحدة في البداية 2- تم التعديل على الأكواد (الغاء الحلقات التكرارية التي ترهق البرنامج في حال كانت البيانات كثيرة) والاستيعاض عنها بدالة Find التي تضع يدها على الصف المناسب رأساً بدون التفتيش في كل الصفوف 3- ما الحاجة الى ادخال 1000 صف في ال ـ TextBox النطاق A2:E1000 من خلال Form Initialize ونحن بحاجة الى القليل منها (البيانات حتى اخر صف غير فارغ) 4- الاكواد بعد التعديل Option Explicit Dim RO%, t% Dim My_sh As Worksheet Dim Sarch_rg As Range Dim Found_rg As Range '++++++++++++++++++++++++++++++++++++++++++++++++++++ Private Sub CommandButton1_Click() 'add Employ Set My_sh = Sheets("sheet1") RO = ws.Cells(Rows.Count, 1).End(3).Row + 1 With My_sh.Cells(RO, 1) .Value = Me.txtcode.Value .Offset(, 1) = Me.txtname.Value .Offset(, 2) = Me.txtjop.Value .Offset(, 3) = Me.txtadress.Value .Offset(, 4) = Me.txtid.Value End With Me.ListBox1.RowSource = "a2:e" & RO End Sub '++++++++++++++++++++++++++++++++++++++++++++++ Private Sub CommandButton2_Click() 'search Set My_sh = Sheets("sheet1") RO = My_sh.Cells(Rows.Count, 1).End(3).Row Set Sarch_rg = My_sh.Range("A1:A" & RO) Set Found_rg = Sarch_rg.Find(txtcode.Text, lookat:=1) If Found_rg Is Nothing Then MsgBox "Not Fount" Exit Sub Else t = Found_rg.Row With My_sh.Cells(t, 1) Me.txtcode.Text = .Value Me.txtname.Text = .Offset(, 1) Me.txtjop.Text = .Offset(, 2) Me.txtadress.Text = .Offset(, 3) Me.txtid.Text = .Offset(, 3) End With End If End Sub '+++++++++++++++++++++++++++++++++++++ Private Sub CommandButton3_Click() 'Remove Set My_sh = Sheets("sheet1") RO = My_sh.Cells(Rows.Count, 1).End(3).Row Set Sarch_rg = My_sh.Range("A1:A" & RO) Set Found_rg = Sarch_rg.Find(txtcode.Text, lookat:=1) If Found_rg Is Nothing Then MsgBox "Not Fount" Exit Sub Else t = Found_rg.Row My_sh.Cells(t, 1).Resize(, 5).Delete End If End Sub '++++++++++++++++++++++++++++++++++++++ Private Sub CommandButton4_Click() Dim txt For Each txt In Frame2.Controls If TypeOf txt Is msforms.TextBox Then txt.Text = "" End If Next txt End Sub '+++++++++++++++++++++++++++++++++ Private Sub CommandButton5_Click() Set My_sh = Sheets("sheet1") Application.Dialogs(xlDialogPrinterSetup).Show My_sh.PrintOut copies:=1 End Sub '+++++++++++++++++++++++++++++++++++ Private Sub CommandButton6_Click() Unload Me End Sub '++++++++++++++++++++++++++++++++ Private Sub CommandButton7_Click() 'Update Set My_sh = Sheets("sheet1") RO = Cells(Rows.Count, 1).End(xlUp).Row Set Sarch_rg = My_sh.Range("A1:A" & RO) Set Found_rg = Sarch_rg.Find(txtcode.Text, lookat:=1) If Found_rg Is Nothing Then MsgBox "Not Fount" Exit Sub Else t = Found_rg.Row With My_sh.Cells(t, 1) .Offset(, 1) = Me.txtname.Text .Offset(, 2) = Me.txtjop.Text .Offset(, 3) = Me.txtadress.Text .Offset(, 4) = Me.txtid.Text End With Me.ListBox1.RowSource = "a2:e" & RO MsgBox "Data Edite Succesufly", vbInformation, "alarm" End If End Sub '+++++++++++++++++++++++++++++++++++++++++++++ Private Sub UserForm_Initialize() Set My_sh = Sheets("sheet1") RO = My_sh.Cells(Rows.Count, 1).End(3).Row Me.ListBox1.ColumnCount = 5 Me.ListBox1.RowSource = "a2:e" & RO End Sub الملف مرفق moh_Form_322.xlsm

السلام عليكم 🙂 اولا خليني ادافع عن نفسي واخبرك سبب التأخير 🙂 الجدول الاول مستحيل تكون نتائجة مثل ما هو موضح في الجدول الثاني ، لأن الفرع ليس نفسه في كل السجلات ، بينما الجمع في الجدول الثاني كان على اعتبار ان جميع الفروع هي نفسها (شوف اسم الفروع اللي عليها السهم ، فهي مختلفة) 🙂 وهذا اخذ مني بقية الشعر اللي على راسي ، من كثر ما حكيت رأسي بالمعادلات والنتائج الخطأ 😁 . والان الى الحل: 1. عملت استعلام مجاميع لكل مجموعة ،المجموعة الاولى للتاريخ ، والثانية للشهر ، بينما الاستعلام الثالث هو لحقول الجدول : . والنتيجة . وعملنا استعلام اخير لجمع هذه الاستعلامات الثلاث: . والنتيجة . جعفر 1285.DCOUNT.mdb.zip

الكود لا يعطي الا أول حلية من ما كان مدمجاً

استاذ على حفظك الله بعد اذنك يمكن استخدام حدث change بدون زر فى حدث الصفحة ليصبح الكود Private Sub Worksheet_Change(ByVal Target As Range) Dim sh As Worksheet For Each sh In ThisWorkbook.Worksheets sh.Columns.AutoFit sh.Rows.AutoFit Next sh End Sub مع الشكر

شكرا استاذنا الفاضل على مرورك العطر وبالنسبة لنفطةالغاء الدمج اتفضل الشيت بعد التعديل نسخة من دمج الخلايا عندما تكون لها نفس القيم-1.xlsm ماشاء الله استاذ سليم دائما سباق بالخير جعله الله فى ميزان حسناتك

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

ملاحظة امكانية اضافة عملاء وحسابات تسلم وتعيش جميل بس انا Zero اكسيس بدأت اتعلم من اليوتيوب لسه kg شكرا لمساعدتك على راسى اخى تسلم

يارا.accdb هبتعتلك نسخة مبداية من التصميم تحت الانشاء ممكن حضرتك تعطيني تفاصيل اكثر اقدر اضيفها يارا_2.rar

اصدار الاوفيس اللي حضرتك شغالة عليه 2010 ولا اقل واو 2016 حددي من فضلك

اسم الحسابات اخى فالله حساب النقدية حساب المؤجلات حساب تحت النسوية حساب الموردين المتعثرين مشكور جدا اكثر الله خيرك

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

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

اخ محمد بخصوص هذ الخطا لديك زر تحكم لهم نفس الاسم عليك تغييره

شكرا اخي الكريم

ولحذف الجدول في حال وجودة استخدم هذا الكود في اعلا الكود السابق .... DoCmd.DeleteObject acTable, "Temp"

ملفك بعد التعديل عليه SS Forms.accdb

أكثر من ذلك تم تطوير الكود بحيث تظهر النتائج في عامود واحد مع ترقيمها Option Explicit Dim F As Worksheet, M As Worksheet Dim L_M%, L_F%, K%, t%, xx%, A% Dim x As Boolean, y As Boolean, z As Boolean Dim D1 As Date, D2 As Date Dim Obj As Object '++++++++++++++++++++++++++++++++++++ Sub fin_Please(Rg1 As Range) D1 = Application.Min(Rg1.Resize(, 2)) D2 = Application.Max(Rg1.Resize(, 2)) For K = 2 To L_M x = IsDate(M.Cells(K, 1)) y = M.Cells(K, 1) >= D1 z = M.Cells(K, 1) <= D2 If x * y * z <> 0 Then Obj(M.Cells(K, 3).Value) = vbNullString End If Next K If Obj.Count Then Rem Typing The Results in the Sheet xx = F.Cells(Rows.Count, 1).End(3).Row + 1 With F.Range("A" & xx) .Value = "From " & F.Range("D" & A) _ & " To " & F.Range("E" & A) .Interior.ColorIndex = 40 With .Offset(1).Resize(Obj.Count) .Value = Application.Transpose(Obj.keys) .Interior.ColorIndex = 35 .Offset(, 1).Value = _ Evaluate("Row(1:" & Obj.Count & ")") .Offset(, 1).Interior.ColorIndex = 19 End With End With Rem End Of Typing The Results in the Sheet End If End Sub '+++++++++++++++++++++++++++++++++++++++ Sub test() Rem Created By Salim Hasbaya On Nov. 17 2020 Application.ScreenUpdating = False Dim First_Col, Second_col%, Mycol% Dim Cel As Range, Mesg$ Set F = Sheets("Final") Set M = Sheets("Main") Set Obj = CreateObject("Scripting.Dictionary") Rem Clear Old Data t = F.Range("A2").CurrentRegion.Rows.Count If t > 1 Then F.Range("A2").CurrentRegion. _ Offset(1).Resize(t - 1).Clear End If Rem End of Clear Old Data L_F = F.Cells(Rows.Count, 4).End(3).Row L_M = M.Cells(Rows.Count, 1).End(3).Row Rem For Control the dates==================== First_Col = L_F Second_col = F.Cells(Rows.Count, 5).End(3).Row If First_Col < 2 Or Second_col < 2 Then Application.ScreenUpdating = True Exit Sub End If Mycol = Application.Max(First_Col, Second_col) For Each Cel In F.Range("D2:E" & Mycol) If Not IsDate(Cel) Then Mesg = Mesg & Cel.Address & Chr(10) End If Next If Mesg <> "" Then MsgBox "Check Up This Cells Please:" & Chr(10) _ & Mesg & Chr(10) & _ "They Must Be A Date" Application.ScreenUpdating = True Exit Sub End If Rem End of For Control the dates ================== Rem Looping Throught the dates in Column D And E For A = 2 To L_F fin_Please (Sheets("Final").Range("D" & A)) Obj.RemoveAll Next Rem end of Looping Throught the dates in Column D And E Rem Format The Results t = F.Range("A2").CurrentRegion.Rows.Count If t > 1 Then With F.Range("A2").CurrentRegion. _ Offset(1).Resize(t - 1).SpecialCells(2, 23) .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 16: .Font.Bold = True End With End If Rem End Of Format The Results Application.ScreenUpdating = True End Sub الملف من جديد Hani_Exact_1.xlsm

وعليكم السلام حيرتنى معاك لأن المعادلة الموجودة بالملف تعمل بكل كفاءة ....واذا أردت تغيير قيمة التقسيم يمكنك تغيير الأرقام الموجودة بداية من الخلية AB10 الى ما تشاء وتريد وشكرا

أحسنت استاذ سليم عمل ممتاز بارك الله فيك وزادك الله من فضله وأدخلك فسيح جناته ... وهو بالفعل المطلوب جزاك الله كل خير ونصر الله لبنان وشعبها

تم معالجة الأمر بعد تطوير الكود ليطعي رسالة خطأ اذا كانت احد الخلايا في العامودين D و E لا تصلح كتاريخ (أو فارغة) Hani_Exact.xlsm

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

ما خط بالاحمر غير مفهوم بل جميع ما كتب اعلاه شرح لمصنف اكسل تم ارفاق جزء منه ، وهذا لا فائدة منه ، اقصد انه غير مفهوم لمن سيقوم بالتصميم والبرمجة , والمعذرة على ردي هذا ، لاني قرأته اكثر من مرة ولم اتوصل لفهم المشروع .. فلعل احدا من اخواننا الاعضاء الكرام يقرأ الشرح اعلاه ويفيدنا عن تصوره لفكرة العمل .

اضف زر في التقرير ثم ضع هذا الكود وظيفته ::: تكوين جدول باسم Temp ثم تصدير البيانات الموجوده في التقرير اليه .... الان تصتطيع فعل ما تشاء سواءا تكوين رسم بياني أو تصديرة للاكسل ... جرب ووافينا بالنتيجة Dim strSQL2 As String strSQL2 = "CREATE TABLE [Temp] ([Assessment] TEXT(5),[Reassessment] TEXT(5), [Multidisciplinary] TEXT(5),[Followup] TEXT(5),[LAMA] TEXT(5),[MLSD] TEXT(5),[Meeting] TEXT(5),[MOH] TEXT(5),[Rounds] TEXT(5),[Total] TEXT(5));" DoCmd.RunSQL strSQL2 On Error Resume Next Dim rs2 As Recordset, Dbs As DAO.Database Set Dbs = CurrentDb Set rs2 = Dbs.OpenRecordset("Temp") rs2.AddNew rs2.Fields(0) = [Reports]![Total of Assessment]![Count] rs2.Fields(1) = [Reports]![Total of Reassessment]![Count] rs2.Fields(2) = [Reports]![Total of Multidisciplinary]![Count] rs2.Fields(3) = [Reports]![Total of Follow up]![Count] rs2.Fields(4) = [Reports]![Total of LAMA]![Count] rs2.Fields(5) = [Reports]![Total of MLSD]![Count] rs2.Fields(6) = [Reports]![Total of meeting]![Count] rs2.Fields(7) = [Reports]![Total of MOH]![Count] rs2.Fields(8) = [Reports]![Total of Rounds]![Count] rs2.Fields(9) = [Assessment] + [Reassessment] + [Multidisciplinary] + [Followup] + [LAMA] + [MLSD] + [Meeting] + [MOH] + [Rounds] rs2.Update Set rs = Nothing

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

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

الاساتذة الأفاضل اشكركم على المساعدة و على رحابة الصدر أنا مازلت اتعلم انشاء قواعد البيانات شكراً من القلب شكراً جزيلاً

وعليكم السلام 🙂 اخي الفاضل ، في المرات القادمة ، رجاء مراعاة قوانين المنتدى بوضع عنوان يدل على محتوى السؤال 🙂 اما سؤالك : خطأ Over Flow معناه ان القيمة اكبر من حجم المتغير ، المتغير x و i عندك integer ، فيجب تكبير هم الى Long . جعفر

الكود اللازم مع التنسيق بعد الترحيل Option Explicit Dim Source As Worksheet Dim Target As Worksheet Dim Mx%, i%, rO% Dim Ar_S Dim Ar_T '++++++++++++++++++++++++++++++++++++++++++++ Sub Fayez() Set Source = Sheets("sheet1") Set Target = Sheets("sheet2") Mx = Target.Cells(Rows.Count, 2).End(3).Row + 1 Ar_S = Array("D7", "D9", "D11", "G7", "G9", "G11", "G13") Ar_T = Array("B", "C", "D", "E", "F", "G", "H") For i = LBound(Ar_S) To UBound(Ar_S) Target.Cells(Mx, Ar_T(i)) = Source.Range(Ar_S(i)) Source.Range(Ar_S(i)) = vbNullString Next 'هذا السطر لحذف البيانات المكررة اذا لا تريده يمكنك حذفه '+++++++++++++++++++++++++++++++++++++++ Target.Range("A1:H" & Mx).RemoveDuplicates _ Columns:=Array(1, 2, 2, 2, 5, 6, 7), Header:=1 '++++++++++++++++++++++++++++++++++++++++ rO = Target.Range("b2").CurrentRegion.Rows.Count If rO > 1 Then With Target.Range("b2").CurrentRegion. _ Offset(1).Resize(rO - 1) .HorizontalAlignment = 1 .Borders.LineStyle = 1 .InsertIndent 1 .Font.Bold = True .Font.Size = 16 .Cells(1, 1).Resize(rO - 1).Value = _ Evaluate("row(1:" & rO - 1 & ")") End With End If End Sub الملف مرفق esam1983.xlsm

في هذا الملف 1- الصفحة Result حيث تظهر النتيجة 3 صفوف تحنوي بيانات مهمه ليغمل عليها الكود الصفوف (5/4/3 مخفية) عدم المس بها كي لا يتعطل عمل الماكرو الصف رقم 5 يجب ان يكون فارغاُ نهائياً لقصل رأس الجدول عن البيانات 2-تكرار البيانات غير مسموح (الماكرو يحذف المكرر اذا كانت جميع بيانات الصف الواجد مكررة) بمعنى اخر اذا كبست الزر اكثر من مرة دون تعديل البيانات لا يعمل الماكرو أكثر من مرة واحدة الماكرو 3 -الزر Clear يمسح البيانات من source التي لا تحتوي على معادلات Option Explicit Sub Get_data() Dim S As Worksheet Dim R As Worksheet Dim i%, m%, Mx% Dim ArS(1 To 20) Dim ArR(1 To 20) Set S = Sheets("Source") Set R = Sheets("Result") m = R.Cells(Rows.Count, 2).End(3).Row + 1 If m < 6 Then m = 6 For i = 2 To 21 ArS(i - 1) = R.Cells(3, i) ArR(i - 1) = R.Cells(4, i) Next For i = 1 To 20 R.Cells(m, ArR(i)).Value = _ S.Range(ArS(i)).Value Next R.Cells(6, 2).Resize(m - 5, 20). _ RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, _ 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20), Header:=xlNo Mx = R.Range("B6").CurrentRegion.Rows.Count If R.Cells(6, 2) <> vbNullString Then With R.Cells(6, 1).Resize(Mx) .Value = Evaluate("Row(1:" & Mx & ")") With .Resize(, 21) .Borders.LineStyle = 1 .Font.Bold = True End With End With End If End Sub الملف مرفق laminedch.xlsm

بعد اذن الاخ علي معادلة احرى (تنسيق الخلايا Percent) =CHOOSE((S3="")+1,CHOOSE(OR(S3="وليد ",S3="سعيد")+1,0.14,0.1),"")

وعليكم السلام 🙂 الحل بأن تضع هذا الكود في حدث ، وبعد اخذ الرقم التالي مباشرة تحفظ السجل ، وعلى افتراض ان اسم الحقل هو Sinf ، يصبح الكود هكذا : بدلا عن =IIf(IsNull(DMax("[id]";"items")+1);1;DMax("[id]";"items")+1) استخدم if len(me.Sinf & "")=0 then me.Sinf = nz(DMax("[id]","items"),0) +1 docmd.runcommand accmdsaverecord end if . جعفر

جربي هذا الكود لمعرفة أرقام كل الألوان Option Explicit Sub get_colore_index() Dim i Cells(1, 1) = "Color Index" Cells(1, 2) = "Color" For i = 2 To 57 With Cells(i, 1) .Value = i - 1 .Offset(, 1).Interior.ColorIndex = i - 1 End With Next End Sub

هذه الصورة توضح الأمر

تم العمل كما تريدين بعد التعديل على الكود Yara_One _more_color.xlsb

تعدبل في الكود

جرب هذا الملف لعله يفيدك هذه معادلة مصفوفة =IFERROR(INDEX($A$2:$A$9;SMALL(IF($F$2=TRIM($A$2:$A$9);ROW($A$2:$A$9)-MIN(ROW($A$2:$A$9))+1;"");ROW(A1)));"") اضغط على CTRL+SHIFT+ENTER بحث.xlsx

جرب هذا الكود Sub get_data() Dim rg As Range Dim ro Sheets("AddShe").Range("A1").CurrentRegion.ClearContents Set rg = Sheets("DatabaseShe").Range("a1").CurrentRegion Sheets("AddShe").Range("A1"). _ Resize(rg.Rows.Count, rg.Columns.Count).Value = _ rg.Value Sheets("AddShe").Range("A1"). _ CurrentRegion.Sort key1:=Range("B2"), Header:=1 ro = Sheets("AddShe").Range("a1").CurrentRegion.Rows.Count Sheets("AddShe").Range("A2").Resize(ro - 1) = _ Evaluate("row(1:" & ro - 1 & ")") End Sub الملف مرفق Saleh.xlsm

اليك هذه الاضافة الى الملف (عسى ان تنال الاعجاب) ايجاد pos_sum و Neg_sum و All_sum بين تاريخين في صفحة واحدة "Test_All" Yara_All_In_One.xlsm

اضيقي الى القائمة النتسدلة عنصر تحت اسم sum15 و عدلي على الكود كما في الصورة الملف Yara_15_Part_Pos_Neg_All.xlsb

استبدلي في القائمة المنسدلة عبارة nagative-positive-nagative*15/100 بكلمة Part وأضيفي الى الكود كما في الصورة في المكان المناسب الملف مرفق Yara_Part_Pos_Neg_All.xlsb

تم التعديل كما تريدين الأعداد السالبة تظهر باللون الأصفر والموجبة بالأخضر(شرط تطابق التاريخ) حلايا التاريخ المطلوب باللون الزهري 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