محمد هشام.

لم تدكر اخي ماهو معيار البحث

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Option Explicit Sub Transfer() Dim wbData As Workbook, wsData As Worksheet Dim rngToCopy As Range, cl As Range Dim C As Long, LastRow As Long Dim wsMain As Worksheet: Set wsMain = ThisWorkbook.ActiveSheet Application.ScreenUpdating = False Set wbData = Workbooks.Open("C:\Users\Ehab Elhady\Desktop\1.xlsx") Set wsData = wbData.Sheets("Sheet1") Set rngToCopy = wsMain.Range("D6,D8,D10,D12,D14,G6,G8,G10,G12,G14") LastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row C = 1 For Each cl In rngToCopy cl.Copy wsData.Cells(LastRow + 1, C).PasteSpecial xlPasteValues C = C + 1 Next cl wbData.Close True Application.CutCopyMode = False MsgBox " تم ترحيل البيانات بنجاح", vbInformation, "تعليمات" End Sub e_V2.rar

جرب وضعه باحدى الطرق التالية Sub test1() Set ws = sheet1 With ws lrw = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row End With 'exemple MsgBox lrw End Sub '''''''''''''''''''''' Sub test2() lrw = Worksheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row 'exemple MsgBox lrw End Sub '''''''''''''''''''''' Sub test4() Dim lrw As Long lrw = Cells(Rows.Count, 1).End(xlUp).Row MsgBox lrw End Sub

تفضل اخي هدا حل اخر على حسب ما فهمت من اخر ملف قمت برفعه تمت اظافة شيت جديد باسم النتائج لاستخراج تقرير كل اسبوع على حده تحت بعض في ورقة واحدة كما في الصورة ادناه . شيت النتائج مع استخراج بيانات كل اسبوع في شيت مستقل بدون تكرار للتواريخ . وحفظ الكل في مجلد في بارتشن (E) فرز بيانات V2.rar

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

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ربما هدا طلبك . تقسيم البيانات كل اسبوع في ورقة مستقلة مع انشاء مجلد في القرص (E) وحفظ الملفات بداخله بصيغة (PDF) مع تنسيق الجداول بنفس التنسيق المرفق في طلبك . Public Sub Split_Sheet_condition_of_the_week() Dim dataSheet As Worksheet, weekSheet As Worksheet Dim minDate As Date, maxDate, weekStartDate As Date Dim lr As Long, c As Long, LastRow As Long, MH As Variant Dim weekSheetName As String, WS_Address As String Dim ST_DATA, ST_Name, ST_Path, ST_WS_Data As String Dim WS_Data As Range, Total_Rng As Range Dim wsData As Worksheet: Set wsData = Worksheets("تجميع") 'حدف جميع اوراق العمل باستثناء ورقة التجميع Application.ScreenUpdating = False For Each ws In Worksheets If ws.Name <> "تجميع" Then Application.DisplayAlerts = False ws.Delete Application.DisplayAlerts = True End If Next Set dataSheet = wsData With dataSheet lr = .Cells(.Rows.Count, "F").End(xlUp).Row 'اصغر تاريخ minDate = Application.WorksheetFunction.Min(.Range("F2:F" & lr)) ' اكبر تاريخ maxDate = Application.WorksheetFunction.Max(.Range("F2:F" & lr)) End With weekStartDate = Date_Prev_Saturday(minDate) While weekStartDate <= maxDate 'تسمية الشيتات weekSheetName = Format(weekStartDate, "d") & " To " & Format(weekStartDate + 6, "d") With ActiveWorkbook Set weekSheet = Nothing On Error Resume Next Set weekSheet = .Worksheets(weekSheetName) On Error GoTo 0 If weekSheet Is Nothing Then 'اظافة وتسمية اوراق العمل Set weekSheet = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count)) weekSheet.Name = weekSheetName weekSheet.DisplayRightToLeft = True Else weekSheet.Cells.Clear End If End With 'فلترة البيانات weekSheet.Range("l1:m1").Value = Array(dataSheet.Range("F1").Value, dataSheet.Range("F1").Value) weekSheet.Range("l2:m2").Value = Array(">=" & CLng(weekStartDate), "<=" & CLng(weekStartDate) + 6) dataSheet.Range("F1:k" & lr).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=weekSheet.Range("l1:m2"), CopyToRange:=weekSheet.Range("A4"), Unique:=False weekSheet.Range("l1:m2").Clear weekSheet.Columns("A:F").EntireColumn.ColumnWidth = 16 LastRow = weekSheet.Cells.SpecialCells(xlCellTypeLastCell).Row Set Total_Rng = Range(weekSheet.Cells(LastRow + 1, "A"), weekSheet.Cells(LastRow + 1, "F")) MH = (RGB(153, 153, 255)) ' اظافة المعادلات weekSheet.Range("F5").Formula = "=COUNTIF(تجميع!$f$2:$f$500,a5)" weekSheet.Range("F5").AutoFill Destination:=Range("F5:F" & LastRow) weekSheet.Range("E5:E" & LastRow) = "=sum(B5*D5)" Cells(LastRow + 1, 1).Value = "المجموع" For c = 2 To 6 Cells(LastRow + 1, c).Value = Application.Sum(Range(Cells(5, c), Cells(LastRow, c))) Next c 'تنسيق الجدول Total_Rng.Interior.Color = MH Total_Rng.Font.Bold = True Total_Rng.Font.Size = 13 With Range("A5:F" & LastRow + 1) .HorizontalAlignment = xlCenter .Font.Name = "Calibri" .Font.Size = 16 .Value = .Value End With 'تسطير الجدول DL = weekSheet.Range("A65500").End(xlUp).Row DC = weekSheet.Cells(5, Columns.Count).End(xlToLeft).Column Range(weekSheet.Cells(5, 1), weekSheet.Cells(DL, DC)).Borders.Weight = xlThin 'فواصل الصفحات With weekSheet.Range("A5:A" & _ weekSheet.Range("A" & Rows.Count).End(xlUp).Row) Set WS_Data = weekSheet.Cells.Find(What:="المجموع", LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, _ SearchDirection:=xlNext) If Not WS_Data Is Nothing Then WS_Address = WS_Data.Address Do If Not WS_Data Is Nothing Then WS_Data.Offset(1).PageBreak = xlPageBreakManual End If Set WS_Data = .FindNext(WS_Data) If WS_Data Is Nothing Then Exit Do End If If WS_Data.Address = WS_Address Then Exit Do End If Loop End If End With On Error Resume Next ActiveWindow.View = xlPageBreakPreview weekSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 ActiveWindow.View = xlNormalView ' إنشاء مجلد الحفظ ST_Name = "فرز البيانات الأسبوعية" ST_DATA = "" ST_WS_Data = "E:\" ' قم بتغييره بما يناسبك 'ST_WS_Data = "D:\" If IsEmpty(ST_Name) Then Exit Sub If IsEmpty(ST_DATA) Then Exit Sub MkDir ST_WS_Data & "\" & ST_Name ST_Path = ST_WS_Data & "\" & ST_Name & "\" & ST_DATA ' مسار وضع الشيتات بصيغة (PDF)""""""""""""""""""""""""""""" مسار مجلد الحفظ weekSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="E:\فرز البيانات الأسبوعية\" & weekSheet.Name & "_" & Format(Now, "MMMM") & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True, OpenAfterPublish:=False weekStartDate = weekStartDate + 7 Wend dataSheet.Select MsgBox "" & ST_WS_Data & ST_Name & vbLf & vbLf & vbLf & "من :" & " " & Format(minDate, "dd/mm/yyyy") & vbLf & vbLf & "إلى :" & " " & Format(maxDate, "dd/mm/yyyy") & " " & _ FolderName, _ vbInformation, " : تم حفظ الملفات بنجاح في " On Error GoTo 0 Application.ScreenUpdating = True End Sub Private Function Date_Prev_Saturday(fromDate As Date) As Date Date_Prev_Saturday = fromDate - Weekday(fromDate) + vbSaturday + 7 * (vbSaturday > Weekday(fromDate)) End Function بالتوفيق.......... تجميع V1.xlsm

وعليكم السلام ورحمة الله وبركاته أخي المرجوا توضيح عدد الأعمدة المراد نسخها عند فلترة التواريخ أو تحديد النطاق المطلوب!!!

=30*(12*SOMME.SI(V2:V6; "مج أ"; N2:N6) +SOMME.SI(V2:V6; "مج أ"; P2:P6) )+SOMME.SI(V2:V6; "مج أ"; R2:R6) حساب الجاميع V2.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي F12 الخلية =SOMME.SI(V2:V7; "مج أ"; N2:N7) + SOMME.SI(V2:V7; "مج أ"; P2:P7) + SOMME.SI(V2:V7; "مج أ"; R2:R7) F14 الخلية =SOMME.SI(V2:V7; "مج ب"; N2:N7) + SOMME.SI(V2:V7; "مج ب"; P2:P7) + SOMME.SI(V2:V7; "مج ب"; R2:R7) حساب الجاميع.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك اخي استخدام المعادلة التالية واتباع بعض الخطوات البسيطة كما في الصورة تحت رغم ان هده الطريقة ربما متعبة من ناحية اظافة الصور او جلبها من الافضل تحديد مكان ثابت لعرض الصور بشرط خلية معينة عند كتابة اسم الشعار يتم جلبه الى المكان المحدد مسبقا https://streamable.com/ocm476 =INDEX(شعار!$A$1:$B$200;EQUIV(البيانات!$A$2;شعار!$A$1:$A$200;0);2) جلب شعار.rar

حاول اخي تحميل الملف من المرفقات وقم بنسخ المعادلات =MAX.SI.ENS($F$2:$F$7000;$C$2:$C$7000;K2) او =MAX(SI($C$2:C7000=K2; $F$2:F7000)) او =SOMMEPROD(MAX(($C$2:$C$7000=K2)*($F$2:$F$7000))) او =MAX(INDEX((K2=$C$2:$C$7000)*$F$2:$F$7000;)) H23_V2.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك استخدام المعادلة التالية =MAX(INDEX((K2=$C$2:$C$17)*$F$2:$F$17;)) H23.xlsx

تفضل اخي ميزانية -اكسل-2023-.rar

تفضل اخي تم تفعيل جميع الاكواد بالنسبة ل 6 تبويبات ملاحظة لتتمكن من عرض ملفات PDF على اليوزرفورم وطباعة التقارير قم بتثبيت برنامج Adobe Acrobat على جهازك قاعدة البيانات.xlsm

شكرا لك اخي @أبو إيمان على التوضيح تفضل اخي Sub TEST_Rng() Dim a As Variant, ST1 As Variant, MH As Variant, ST3 As Object Dim WS_Data As Object, ST2 As Range, Data_Cells As Range, i As Long, Idx As Long Dim WS_Réf As Worksheet Set WS_Réf = ThisWorkbook.Sheets("Sheet1") Application.ScreenUpdating = False If WS_Réf.AutoFilterMode Then WS_Réf.AutoFilterMode = False Set ST2 = WS_Réf.Range("C2:F" & Range("C" & Rows.Count).End(xlUp).Row) ST2.Interior.ColorIndex = xlNone a = Application.Index(ST2.Value2, , 1) Set WS_Data = CreateObject("Scripting.Dictionary") WS_Data.CompareMode = vbTextCompare For i = 1 To UBound(a) If a(i, 1) <> "" Then WS_Data(a(i, 1)) = WS_Data(a(i, 1)) + 1 Next MH = Array(RGB(255, 128, 128), RGB(204, 255, 255), RGB(51, 204, 204), RGB(153, 153, 255), RGB(0, 255, 0), RGB(204, 204, 204), _ RGB(255, 102, 0), _ RGB(204, 204, 155), RGB(255, 255, 0), RGB(255, 153, 0), RGB(255, 0, 255)) For Each ST1 In WS_Data.keys If WS_Data(ST1) > 1 Then ST2.Offset(-1).AutoFilter 1, ST1 WS_Réf.AutoFilter.Range.Offset(1).Interior.Color = MH(Idx) Idx = Idx + 1 End If Next If WS_Réf.AutoFilterMode Then WS_Réf.AutoFilterMode = False ST2.Offset(ST2.Rows.Count).Resize(1).Interior.Color = xlNone For Each ST3 In WS_Réf.Range("C2:F500").Cells If ST3.Value = "" Then If Data_Cells Is Nothing Then Set Data_Cells = Range(ST3.Address) Else Set Data_Cells = Union(Data_Cells, Range(ST3.Address)) End If End If Next Data_Cells.Interior.ColorIndex = xlNone Application.ScreenUpdating = True End Sub في حالة الرغبة بالتعامل مع جدول Sub Color_Tbl() Dim a As Variant, MH As Variant, ST4 As Variant Dim Tab_WS As ListObject, ST5 As Object, WS_Data As Object Dim ST_Idx As Long, ST6 As Range, i As Long Dim Data_Cells As Range Dim ST_Réf As Worksheet Set ST_Réf = ThisWorkbook.Sheets("Sheet2") Application.ScreenUpdating = False Set Tab_WS = ST_Réf.ListObjects("Tableau1") Tab_WS.Range.AutoFilter Set ST6 = Tab_WS.DataBodyRange ST6.Interior.ColorIndex = xlNone a = Application.Index(ST6.Value2, , 1) Set WS_Data = CreateObject("Scripting.Dictionary") WS_Data.CompareMode = vbTextCompare For i = 1 To UBound(a) If a(i, 1) <> "" Then WS_Data(a(i, 1)) = WS_Data(a(i, 1)) + 1 Next MH = Array(RGB(255, 128, 128), RGB(204, 255, 255), RGB(51, 204, 204), _ RGB(255, 102, 0), RGB(204, 204, 155), RGB(255, 255, 0), _ RGB(255, 153, 0), RGB(255, 0, 255), RGB(153, 153, 255), RGB(0, 255, 0), RGB(204, 204, 204)) For Each ST4 In WS_Data.keys If WS_Data(ST4) > 1 Then Tab_WS.Range.AutoFilter 1, ST4 Tab_WS.Range.Offset(1).Interior.Color = MH(ST_Idx) ST_Idx = ST_Idx + 1 End If Next Tab_WS.Range.AutoFilter ST6.Offset(ST6.Rows.Count).Resize(1).Interior.Color = xlNone For Each ST5 In ST_Réf.Range("C2:F500").Cells If ST5.Value = "" Then If Data_Cells Is Nothing Then Set Data_Cells = Range(ST5.Address) Else Set Data_Cells = Union(Data_Cells, Range(ST5.Address)) End If End If Next Data_Cells.Interior.ColorIndex = xlNone End Sub بالتوفيق....... countif_V7.xlsm

تفضل اخي تم تعديل الكود ليشتغل معك تلقائيا عند التغيير في عمود (c) واظافة امكانية اختيار الالوان . يمكنك تعديلها على حسب احتياجاتك . '''تنبيه عند تكرار نفس القيمة في العمود اكثر من 10 مرات Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim cell As Range Dim myrng As Range Dim clr As Long Dim lastCell As Range Dim MH As Variant Dim Idx As Long With Target ' تحديد رقم العمود الهدف If (.Column <> 3) Or .Cells.Count > 10 Then Exit Sub On Error Resume Next ' تحديد اقصى عدد للتكرار المسموح به If WorksheetFunction.CountIf(Columns(.Column), .Value) > 10 Then 'حدف القيمة المدخلة .clear MsgBox "لايمكن طباعة أكثر من 10", vbMsgBoxRight + vbOKOnly, "لا يمكن الاستمرار" End If End With Set ws = ThisWorkbook.Sheets("Sheet1") 'النطاق الهدف Set myrng = ws.Range("c2:f" & Range("c" & ws.Rows.Count).End(xlUp).Row) ' نطاق الشرط Set myrng2 = ws.Range("c2:c" & Range("c" & ws.Rows.Count).End(xlUp).Row) With myrng Set lastCell = .Cells(.Cells.Count) End With myrng.Interior.ColorIndex = xlNone 'تحديد الالوان MH = Array(RGB(255, 128, 128), RGB(204, 255, 255), RGB(51, 204, 204), RGB(204, 204, 204), _ RGB(153, 204, 0), RGB(255, 102, 0), RGB(255, 128, 128), _ RGB(204, 204, 155), RGB(255, 255, 0), RGB(255, 153, 0), RGB(0, 255, 0), RGB(255, 0, 255)) For Each cell In myrng If Application.WorksheetFunction.CountIf(myrng2, cell) > 1 Then If myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Address = cell.Address Then cell.Interior.Color = MH(Idx) Idx = Idx + 1 Else cell.Interior.ColorIndex = myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Interior.ColorIndex End If End If Next ' يمكنك تغعيل السطر التالي في حالة الرغبة في استخراج عدد التكرار 'Call test3 End Sub countif_V5.xlsm

تفضل اخي countif_V4.xlsm

بما انك لم تقم بالاجابة سوف احاول وضع جميع الاحتمالات الواردة بخصوص السؤال الاول يمكنك اختيار ما يناسبك ووضعه في حدث الشيت ''تنبيه عند تكرار نفس القيمة في العمود اكثر من 10 مرات Private Sub Worksheet_Change(ByVal Target As Range) With Target ' تحديد رقم العمود الهدف If (.Column <> 3) Or .Cells.Count > 10 Then Exit Sub ' تحديد اقصى عدد للتكرار المسموح به If WorksheetFunction.CountIf(Columns(.Column), .Value) > 10 Then 'حدف القيمة المدخلة .ClearContents MsgBox "لايمكن طباعة أكثر من 10", vbMsgBoxRight + vbOKOnly, "لا يمكن الاستمرار" End If End With End Sub ''''''''''''''''''''''''''''' Private Sub Worksheet_Change(ByVal Target As Range) ' تنبيه عند تجاوز عدد القيم على العمود 10 قيم Dim ws As Worksheet Set ws = Sheet1 Dim LastRow As Long Application.ScreenUpdating = False LastRow = ws.Range("C65000").End(xlUp).Row DataCount = Application.WorksheetFunction.CountA(ws.Range("C:C")) ' تجديد عدد القيم المسموح بها If DataCount > 10 Then MsgBox "لايمكن طباعة أكثر من 10", vbMsgBoxRight + vbOKOnly, "لا يمكن الاستمرار" 'حدف القيمة المدخلة ws.Cells(Rows.Count, "c").End(xlUp).ClearContents End If End Sub اما بخصوص السؤال الثاني Sub test1() ' تلوين المجموعات في النطاق المطلوب اينما وجد التكرار ' قم بظبط الاعدادات بما يناسبك Const FirstRow As Long = 2 ' اول صف Const FirstColumn As String = "C" 'اول عمود Const LastColumn As String = "F" ' اخر عمود Dim dict As Object Dim Ky As Variant Dim rng As Range Dim Arr As Variant Dim Rl As Long Dim Cols As Variant Dim Idx As Long Dim Sp() As String Dim c As Long Dim R As Long 'أضف العديد من الألوان كما يحلو لك Cols = Array(65535, 10086143, 16763904, 15123099, 9359529, 11854022, 32896, 65280, 16711680, 65535, 16711935, _ 16763904, 13434828, 16764057, _ 13408767, 16751052, 10079487) Application.ScreenUpdating = False Set dict = CreateObject("Scripting.Dictionary") With Worksheets("Sheet1") ' اسم الورقة الخاص بك ' حدف التنسيقات السابقة Columns("C:F").Interior.Pattern = xlNone For c = Columns(FirstColumn).Column To Columns(LastColumn).Column Rl = .Cells(.Rows.Count, c).End(xlUp).Row If Rl >= FirstRow Then Set rng = .Range(.Cells(1, c), .Cells(Rl, c)) Arr = rng.Value For R = FirstRow To Rl If Len(Arr(R, 1)) Then ' تسجيل عنوان كل خلية غير فارغة حسب القيمة dict(Arr(R, 1)) = dict(Arr(R, 1)) & "," & _ Cells(R, c).Address End If Next R End If Next c For Each Ky In dict Sp = Split(dict(Ky), ",") ' شرط عدد التكرار لتنفيد الامر If UBound(Sp) > 1 Then ' تطبيق نفس اللون على نفس القيم For c = 1 To UBound(Sp) .Range(Sp(c)).Interior.Color = Cols(Idx) Next c Idx = Idx + 1 ' إعادة تدوير الألوان إذا كانت غير كافية If Idx > UBound(Cols) Then Idx = LBound(Cols) End If Next Ky End With Application.ScreenUpdating = True End Sub ''''''''''''''''''''''''''''''''''''''''' '("C") تلوين المجموعات بشرط تكرارها في عمود Sub test2() Dim ws As Worksheet Dim cell As Range Dim myrng As Range Dim clr As Long Dim lastCell As Range Set ws = ThisWorkbook.Sheets("Sheet1") 'النطاق الهدف Set myrng = ws.Range("c2:f" & Range("c" & ws.Rows.Count).End(xlUp).Row) ' نطاق الشرط Set myrng2 = ws.Range("c2:c" & Range("c" & ws.Rows.Count).End(xlUp).Row) With myrng Set lastCell = .Cells(.Cells.Count) End With myrng.Interior.ColorIndex = xlNone clr = 3 For Each cell In myrng If Application.WorksheetFunction.CountIf(myrng2, cell) > 1 Then If myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Address = cell.Address Then cell.Interior.ColorIndex = clr clr = clr + 1 Else cell.Interior.ColorIndex = myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Interior.ColorIndex End If End If Next End Sub ولاستخراج القيم وعدد تكرارها يمكنك استخدام الكود التالي Sub test3() ' عدد القيم المكررة Dim rng As Range Dim var As Variant Dim i As Integer Dim ws As Worksheet Set ws = Sheet1 lr = Range("C65536").End(xlUp).Row Set myrng = ws.Range("M1:N" & Range("c" & ws.Rows.Count).End(xlUp).Row) Application.ScreenUpdating = False myrng.clear ws.[M1] = "القيم" ws.[N1] = "عدد التكرار" i = 0 Set d = CreateObject("Scripting.Dictionary") For Each rng In ws.Range("c2:f" & lr) If rng <> "" Then If d.exists(rng.Value) Then d(rng.Value) = d(rng.Value) + 1 Else d.Add rng.Value, 1 End If End If Next For Each var In d.keys '(M) سيتم وضع الاسماء في العمود '(N)وعدد تكرارها في العمود Range("M" & (i + 2)) = var Range("N" & (i + 2)) = d(var) i = i + 1 Next myrng.Borders.Weight = xlThin Range("N2:N" & lr).Font.Color = 255 Set d = Nothing Application.ScreenUpdating = True End Sub واليك الملف عليه جميع الاكواد اختر ما يناسبك بالتوفيق countif_V2.xlsm countif_V3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تاكد اخي من تطابق الارقام في شيت أسماء الطلاب مع عمود القائمة المنسدلة الموجودة في شيت البيانات الأساسية التقرير السلوكي معدل نهاية ف 2 لعام 2022-2023.xlsx

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

ماذا تقصد بجمع الفورم اخي ؟

وعليكم السلام ورحمة الله تعالى وبركاته Private Sub Sumrng_Click() TextBox1.Value = WorksheetFunction.SUM(sheet1.Range(Range("P7"), Range("P20"))) End Sub test.xlsm

يجب أولا أخي تنظيم الملف وحذف ارتباطات القوائم المنسدلة وتصحيحها ليسهل فهم المطلوب .مع توضيح اسم أو رقم العمود الذي يتم بموجبه تنفيذ الكود. السؤال ما دور الجدول الموجود يسار ورقة العمل ؟

قد تم ملاحظة ذالك وافينا بالنتيجة بعد تجربت الكود

Sub Formula_data() Dim dataWS As Worksheet Dim ST1 As String, ST2 As String Set dataWS = Worksheets("جدول توزيع الحصص") Application.ScreenUpdating = False ST1 = Replace("=IFERROR(INDEX(Data2,MATCH(RC[51],Day,0),MATCH(R6C2,R6C2:R6C7,0)),"""")", _ "dataWS", "'" & dataWS.Name & "'") ST2 = Replace("=IFERROR(INDEX(Data2,MATCH(RC[51],Day,0),MATCH(R6C6,R6C2:R6C7,0)),"""")", _ "dataWS", "'" & dataWS.Name & "'") With dataWS.Range("H7:H" & Range("B" & Rows.Count).End(3).Row) .Formula = "=CONCATENATE(C7, D7,""."",G7)" .Value = .Value For st3 = 7 To 94 Step 2 dataWS.Range(Cells(st3, "M"), dataWS.Cells(st3, "BE")).Formula = ST1 dataWS.Range(Cells(st3 + 1, "M"), dataWS.Cells(st3 + 1, "BE")).Formula = ST2 Next st3 End With With dataWS.Range("m7:be" & Range("L" & Rows.Count).End(3).Row) .Value = .Value End With End Sub