محمد هشام.

ربما هدا ما تقصده تعديل فورم V6 -.rar

Option Explicit Sub test() Dim arr As Variant, i As Long, Irow As Long Dim dictA As Object, dictB As Object, dictC As Object, dictD As Object Dim n As Variant, a As Variant, b As Variant, c As Variant Dim WS As Worksheet: Set WS = Sheets("Sheet1") With WS Irow = .Columns("A:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If WorksheetFunction.CountA(.Range("A2:A" & Irow)) = 0 And _ WorksheetFunction.CountA(.Range("B2:B" & Irow)) = 0 Then MsgBox "لا توجد بيانات للمقارنة", vbExclamation Exit Sub End If 'Code ............. .................. Set dictC = CreateObject("Scripting.Dictionary") Set dictD = CreateObject("Scripting.Dictionary") For i = 2 To Irow If WS.Cells(i, 3).Value <> "" Then dictC(WS.Cells(i, 3).Value) = True If WS.Cells(i, 4).Value <> "" Then dictD(WS.Cells(i, 4).Value) = True Next i For i = 2 To Irow If WS.Cells(i, 1).Value <> "" Then If dictC.exists(WS.Cells(i, 1).Value) Or dictD.exists(WS.Cells(i, 1).Value) Then WS.Cells(i, 1).Interior.Color = RGB(255, 255, 0) End If End If If WS.Cells(i, 2).Value <> "" Then If dictC.exists(WS.Cells(i, 2).Value) Or dictD.exists(WS.Cells(i, 2).Value) Then WS.Cells(i, 2).Interior.Color = RGB(255, 165, 0) End If End If Next i Application.ScreenUpdating = True End Sub مقارنة 3.xlsb

لا علاقة له بالمسلسل التحديد يتم بواسطة رقم الصف

نعم التعديل والاظافة ليس لها علاقة بالمسلسل انت من تضيفه يدويا فقط يتم فقدانه في حالة حدف الصف

نعم اخي المشكلة في طريقة البحث التي تستخدمها لهدا سنعتمد على طريقة متقدمة نوعا ما لتنفيد طلبك وتحديد الصف بدون الاعتماد على إسم او رقم الملف مع اظافة إمكانية البحث والفلترة بأي عمود Private Sub ListBox1_Click() Dim lastRow As Long: lastRow = f.Rows.Count f.Range("A7:A" & lastRow).Interior.ColorIndex = xlNone For i = 1 To OnRng Me("textbox" & i) = Me.ListBox1.Column(i - 1) Next i Me.N_ligne = Me.ListBox1.Column(i - 1) rng = Me.N_ligne + 6 If rng > 0 Then With f .Range(.Cells(rng, "C"), .Cells(rng, "N")).Select .Cells(rng, "A").Interior.Color = RGB(0, 0, 255) End With End If End Sub تعديل فورم V5 -.rar

أعتدر أخي @عادل ابوزيد خطأ لم انتبه له😂 الكود ينفد طلبك لاكن يجب وضع قيمة البحث بعد الصف الخاص بنقل البيانات لعناصر التيكست بهدا الشكل ليس قبلها للتوضيح 1) الفكرة انه يقوم بتحديد الصف بناءا على قيمة textbox4 في عمود ( F ) اسم صاحب المعاش يمكنك تعديلها بما يناسبك For i = 0 To 11 Controls("TextBox" & (i + 1)).Value = IIf(ListBox1.ListIndex <> -1, ListBox1.Column(i), "") Next i Clé = TextBox4.Value 2) في حالة كانت لديك أسماء مكررة يمكنك اظافة شروط اخرى كما في المثال التالي بحيث سنعتمد على اسم صاحب المعاش و رقم الملف وعند التحقق من تطابق الشرطين سيتم تحديد الصف وفي حالة وجود تكرار لنفس البيانات سيقوم بتحديد جميع الصفوف المكررة يمكنك تحميل الملف في المشاركة السابقة بعد تصحيح الخطأ وإختيار ما يناسبك Private Sub ListBox1_Click() Dim ws As Worksheet, OnRng As Range, ColFind As Range Dim Colstar As Integer, ColEnd As Integer, n As Long Dim Clé As Variant, Clé2 As Variant, tmp As Range, f As String, i As Byte Set ws = Sheets("البداية") Colstar = 3: ColEnd = 14 For i = 0 To 11 Controls("TextBox" & (i + 1)).Value = ListBox1.Column(i) Next i TextBox15.Value = ListBox1.ListIndex + 1 Clé = TextBox4.Value: Clé2 = TextBox3.Value Set tmp = Nothing n = 0 Set OnRng = ws.Range(ws.Cells(7, "F"), ws.Cells(ws.Rows.Count, "F").End(xlUp)) Set ColFind = OnRng.Find(Clé, LookIn:=xlValues, LookAt:=xlWhole) If Not ColFind Is Nothing Then f = ColFind.Address Do If ws.Cells(ColFind.row, "E").Value = Clé2 Then n = n + 1 If tmp Is Nothing Then Set tmp = ColFind.EntireRow Else Set tmp = Union(tmp, ColFind.EntireRow) End If End If Set ColFind = OnRng.FindNext(ColFind) Loop While Not ColFind Is Nothing And ColFind.Address <> f End If If n > 0 Then On Error Resume Next ws.Activate If Not tmp Is Nothing Then Dim rng As Range For Each row In tmp.Rows If rng Is Nothing Then Set rng = ws.Range(ws.Cells(row.row, Colstar), ws.Cells(row.row, ColEnd)) Else Set rng = Union(rng, ws.Range(ws.Cells(row.row, Colstar), ws.Cells(row.row, ColEnd))) End If Next row rng.Select End If On Error GoTo 0 End If End Sub

بعد إدن الأستاد @عبدالله بشير عبدالله تعديل بسيط على الكود الخاص به أخي @reem2009a جرب بهذه الطريقة لا تحتاج لتحديد مسار سطح المكتب. عند تنفيذ الكود سيفتح لك مربع حوار لإختار ملف رقم1 وملف رقم2 مما سيغنيك عن تحديد أسماء المصنفات داخل الكود ربما يناسبك filePath1 = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", , "Select First File") If filePath1 = "False" Then Exit Sub filePath2 = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", , "Select Second File") If filePath2 = "False" Then Exit Sub On Error GoTo ErrorHandler Set wb1 = Workbooks.Open(filePath1) Set wb2 = Workbooks.Open(filePath2) Set resultWs = ThisWorkbook.Sheets("Sheet1") resultWs.Cells.ClearContents resultWs.Range("A1:D1").Value = Array("اسم الموظف", "الحالة", _ Left(wb1.Name, InStrRev(wb1.Name, ".") - 1), Left(wb2.Name, InStrRev(wb2.Name, ".") - 1)) 'Code........... End Sub نتائج المقارنة.xlsb

Private Sub ListBox1_Click() Dim i As Byte, Clé As Variant Dim WS As Worksheet, ColF As Range Dim Colstar As Integer, ColEnd As Integer Set WS = Sheets("البداية") Colstar = 3 ColEnd = 14 For i = 0 To 11 Controls("TextBox" & (i + 1)).Value = IIf(ListBox1.ListIndex <> -1, ListBox1.Column(i), "") Next i Clé = TextBox4.Value Set ColF = WS.Columns("F").Find(What:=Clé, LookIn:=xlValues, LookAt:=xlWhole) If Not ColF Is Nothing Then WS.Activate WS.Range(WS.Cells(ColF.row, Colstar), WS.Cells(ColF.row, ColEnd)).Select End If End Sub With ComboBox1 .Clear .AddItem "رقم الملف": .AddItem "الفاحص": .AddItem "اسم المراجع" End With UserForm_Initialize TextBox13.Value = "": ComboBox1.Value = "" Label15.Caption = "" تعديل فورم.rar

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Dim i As Integer Dim WS As Worksheet: Set WS = Sheet5 For i = 2 To 30 WS.Cells(i - 1, 3).Value = Me.Controls("TextBox" & i).Value Next i

أخي @المغفوري 1 ) الرموز الظاهرة معك ليست خطأ هده رسالة (تم التعديل بنجاح ) لحل مشكلة طلاسم اللغة العربية عليك مراجعة ظبط اعدادات اللغة العربية على جهازك 2) الكود مفاده إذا تم العثور على مطابقة للإسم يتم تحديث البيانات (من العمود B إلى L ) صراحة لا أعلم ما تحاول فعله بالظبط حاول تجربة الكود المقترح في المشاركة السابقة بعد تعديله ووافينا بالنتيجة متابعة الطلاب.xlsb

ادن جرب هدا Option Explicit Sub UpdateData() Dim WS As Worksheet, F As Worksheet Dim i As Long, j As Long, a As Long Dim Clé As Long, found As Boolean, modified As Boolean Set WS = Sheet1 ' <<=== ' 'Worksheets("بيانات الطلاب") Set F = Sheet3 ' <<=== ' 'Worksheets("متابعة الطلاب") Clé = 1 ' <<=== ' الاسم ( يمكنك تعديله بما يناسبك )' عمود الشرط Application.ScreenUpdating = False modified = False For i = 4 To F.Cells(F.Rows.Count, Clé).End(xlUp).Row Dim tmp As String: tmp = F.Cells(i, Clé).Value found = False For j = 3 To WS.Cells(WS.Rows.Count, Clé).End(xlUp).Row If WS.Cells(j, Clé).Value = tmp Then For a = 2 To 12 WS.Cells(j, a).Value = F.Cells(i, a).Value Next a found = True modified = True Exit For End If Next j If Not found Then Debug.Print "No match for: " & tmp End If Next i Application.ScreenUpdating = True If modified Then MsgBox "Updated successfully", vbInformation End Sub

نعم اخي @المغفوري هي عبارة عن استعلام لاكن ادا كنت تقصد انك ترغب بعد استدعائها ان تقوم بتعديلها مثلا وتحديثها على ورقة بيانات الطلاب جرب هدا Option Explicit Sub UpdateData() Dim WS As Worksheet, F As Worksheet, i As Long, j As Long Dim n As Boolean Set WS = Worksheets("بيانات الطلاب") Set F = Worksheets("متابعة الطلاب") If F.Cells(F.Rows.Count, 1).End(xlUp).Row < 4 Then Exit Sub Application.ScreenUpdating = False n = False For i = 4 To F.Cells(F.Rows.Count, 1).End(xlUp).Row For j = 3 To WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If WS.Cells(j, 1).Value = F.Cells(i, 1).Value Then WS.Cells(j, 2).Resize(, 10).Value = F.Cells(i, 2).Resize(, 10).Value n = True Exit For End If Next j Next i Application.ScreenUpdating = True If n Then MsgBox "تم التعديل بنجاح", vbInformation, "تأكيد" End If End Sub متابعة الطلاب.xlsb

تفضل أخي @mk_mk_79 Sub CopyHeaders() Dim lastRow As Long, tmp As Long Dim n As Long, Irow As Long, ColArr As Variant Dim WS As Worksheet: Set WS = Sheets("Sheet1") lastRow = WS.Cells(Rows.Count, "F").End(xlUp).Row Irow = 9 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual WS.Range("W" & Irow & ":Y" & WS.Rows.Count).ClearContents tmp = 7 Do While tmp <= lastRow If Not IsEmpty(WS.Cells(tmp, "F")) And Not _ IsEmpty(WS.Cells(tmp, "L")) And Not IsEmpty(WS.Cells(tmp, "R")) Then ColArr = Array(WS.Cells(tmp, "F").Value, _ WS.Cells(tmp, "L").Value, WS.Cells(tmp, "R").Value) n = 0 Do While tmp + n <= lastRow And _ (Not IsEmpty(WS.Cells(tmp + n, "F")) Or _ Not IsEmpty(WS.Cells(tmp + n, "L")) Or _ Not IsEmpty(WS.Cells(tmp + n, "R"))) n = n + 1 Loop With WS.Range(WS.Cells(Irow, "W"), WS.Cells(Irow + n - 1, "W")) .Value = ColArr(0) .Offset(0, 1).Value = ColArr(1) .Offset(0, 2).Value = ColArr(2) End With Irow = Irow + n + 3 tmp = tmp + n Else tmp = tmp + 1 End If Loop Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub طلبات v2 .xls

وعليكم السلام ورحمة الله تعالى وبركاته إليك المثال التالي أقل تاريخ.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub CopyHeaders() Dim lastRow As Long, tmp As Long, Irow As Long Dim WS As Worksheet: Set WS = Sheets("Sheet1") Application.ScreenUpdating = False lastRow = WS.Cells(Rows.Count, "F").End(xlUp).Row tmp = 7 Irow = 2 WS.Range("W8:Y" & WS.Rows.Count).ClearContents Do While tmp <= lastRow If Not IsEmpty(WS.Cells(tmp, "F")) And Not _ IsEmpty(WS.Cells(tmp, "L")) And Not IsEmpty(WS.Cells(tmp, "R")) Then With WS.Cells(tmp + Irow, "W") .Value = WS.Cells(tmp, "F").Value .Offset(0, 1).Value = WS.Cells(tmp, "L").Value .Offset(0, 2).Value = WS.Cells(tmp, "R").Value End With Do While tmp <= lastRow And _ (Not IsEmpty(WS.Cells(tmp, "F")) Or Not _ IsEmpty(WS.Cells(tmp, "L")) Or Not IsEmpty(WS.Cells(tmp, "R"))) tmp = tmp + 1 Loop Else tmp = tmp + 1 End If Loop Application.ScreenUpdating = True End Sub طلبات (1).xls

Function irow(ws As Worksheet, tmp As String) As Long Dim lastrow As Long, i As Long lastrow = ws.Cells(ws.Rows.Count, "E").End(xlUp).row For i = 7 To lastrow If ws.Cells(i, 5).Value = tmp Then irow = i Exit Function End If Next i irow = -1 End Function تعديل Private Sub CommandButton2_Click() Dim ws As Worksheet, linge As Long, i As Long Dim ColArr As Variant, arr() As Variant Set ws = ThisWorkbook.Sheets("البداية") Dim tmp As String: tmp = Me.TextBox3.Value If tmp = "" Then: MsgBox "الرجاء إدخال رقم الملف", vbExclamation, "خطأ": Exit Sub linge = irow(ws, tmp) If linge = -1 Then: MsgBox "رقم الملف غير موجود", vbExclamation, "خطأ": TextBox3.SetFocus: Exit Sub If MsgBox("هل أنت متأكد أنك تريد تعديل بيانات " & Me.TextBox4.Value & "؟", vbYesNo + vbQuestion, "تأكيد") = vbYes Then ColArr = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N") arr = Array(Me.TextBox1.Value, Me.TextBox2.Value, Me.TextBox3.Value, _ Me.TextBox4.Value, Me.TextBox5.Value, Me.TextBox6.Value, _ Me.TextBox7.Value, Me.TextBox8.Value, Me.TextBox9.Value, _ Me.TextBox10.Value, Me.TextBox11.Value, Me.TextBox12.Value) Application.ScreenUpdating = False For i = LBound(arr) To UBound(arr) If i <= UBound(ColArr) Then ws.Cells(linge, ColArr(i)).Value = arr(i) End If Next i UserForm_Initialize Application.ScreenUpdating = True MsgBox "تم تعديل البيانات بنجاح", vbInformation End If End Sub ترحيل Private Sub CommandButton1_Click() Dim ws As Worksheet, lastrow As Long Dim arr() As Variant, ColArr As Variant, tmp As String Set ws = ThisWorkbook.Sheets("البداية") lastrow = ws.Cells(ws.Rows.Count, "E").End(xlUp).row tmp = Me.TextBox3.Value If tmp = "" Then MsgBox "الرجاء إدخال رقم الملف", vbExclamation, "خطأ": Exit Sub If TextBox4.Value = "" Then MsgBox "يرجى ادخال اسم صاحب المعاش", vbExclamation: TextBox4.SetFocus: Exit Sub If TextBox6.Value = "" Then MsgBox "يرجى ادخال اسم الفاحص", vbExclamation: TextBox6.SetFocus: Exit Sub If WorksheetFunction.CountIf(ws.Range("E7:E" & lastrow), tmp) > 0 Then MsgBox "رقم الملف موجود بالفعل", vbExclamation, "تكرار رقم الملف": Exit Sub End If ColArr = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N") arr = Array(Me.TextBox1.Value, Me.TextBox2.Value, tmp, TextBox4.Value, _ Me.TextBox5.Value, TextBox6.Value, Me.TextBox7.Value, _ Me.TextBox8.Value, Me.TextBox9.Value, Me.TextBox10.Value, _ Me.TextBox11.Value, Me.TextBox12.Value) Application.ScreenUpdating = False For i = LBound(arr) To UBound(arr) ws.Cells(lastrow + 1, ColArr(i)).Value = arr(i) Next i With ws.Range("C7:C" & ws.Cells(ws.Rows.Count, "D").End(xlUp).row) .Value = Evaluate("ROW(" & .Address & ")-6") End With For Each ctrl In Me.Controls If TypeName(ctrl) = "TextBox" Then ctrl.Value = "" Next ctrl UserForm_Initialize Application.ScreenUpdating = True MsgBox "تم إدخال البيانات بنجاح", vbInformation, "نجاح" End Sub تعديل فورم.rar

وعليكم السلام ورحمة الله تعالى وبركاته Option Compare Text Dim f, Rng, wsData() Private Sub UserForm_Initialize() Dim f As Worksheet, Rng As Range Dim wsData As Variant, i As Long Set f = Sheets("البداية") Set Rng = f.Range("C7:N" & f.Cells(f.Rows.Count, "E").End(xlUp).row) wsData = Rng.Value For i = LBound(wsData, 1) To UBound(wsData, 1) Dim j As Long For j = 2 To 11 If IsDate(wsData(i, j)) Then wsData(i, j) = Format(wsData(i, j), "yyyy/mm/dd") Next j Next i With ListBox1 .ColumnWidths = "35;70;65;100;110;65;70;75;70;70;70;100" .ColumnCount = 12: .Font.Size = 9: .Font.Name = "Mudir MT" .List = wsData End With With ComboBox1 .AddItem "رقم الملف": .AddItem "الفاحص": .AddItem "اسم المراجع" End With 'Code............. End Sub Private Sub ListBox1_Click() Dim i As Byte, Rng As Long Dim Colstar As Integer, ColEnd As Integer Dim ws As Worksheet: Set ws = Sheets("البداية") Colstar = 4: ColEnd = 14 If ListBox1.ListIndex = -1 Then MsgBox "يرجى اختيار صف من القائمة", vbExclamation Exit Sub End If For i = 0 To 11 If IsDate(ListBox1.Column(i)) Then Controls("TextBox" & i + 1).Value = Format(ListBox1.Column(i), "yyyy/mm/dd") Else Controls("TextBox" & i + 1).Value = ListBox1.Column(i) End If Next i TextBox15.Value = ListBox1.ListIndex + 1 Rng = ListBox1.ListIndex + 7 With ws .Activate .Range(.Cells(Rng, Colstar), .Cells(Rng, ColEnd)).Select End With End Sub تعديل فورم.rar

وعليكم السلام ورحمة الله تعالى وبركاته لست متأكدا مما تحاول فعله لاكن جرب هدا =IF(OR(F23="الأول", F23="الثاني"), IF(COUNTIF($B$11:$I$15, "ق") >= 25, 25, COUNTIF($B$11:$I$15, "ق")), COUNTIF($B$11:$I$15, "ق")) او =IF(OR(F23="الأول", F23="الثاني"), MIN(25, COUNTIF($B$11:$I$15, "ق")), COUNTIF($B$11:$I$15, "ق"))

إدن لنفترض أننا سنقوم باستخراج البيانات من الأعمدة H:M كما هو ظاهر لديك على الصورة إلى ورقة 2 مثلا Sub CreateShift() Dim lastRow As Long, i As Long, j As Long, kay As String, c As String Dim tbl As Variant, Names As Collection, cell As Range, name As String Dim WS As Worksheet: Set WS = Sheets("Sheet1") Dim dest As Worksheet: Set dest = Sheets("Sheet2") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual If Application.WorksheetFunction.CountA(dest.Cells) > 0 Then dest.UsedRange.Clear lastRow = WS.Cells(WS.Rows.Count, 8).End(xlUp).Row tbl = WS.Range("H4:M" & lastRow).Value For i = 1 To lastRow - 3 dest.Cells(1, i + 1).Value = tbl(i, 2) dest.Cells(2, i + 1).Value = tbl(i, 1) If Application.CountA(Application.Index(tbl, i, 3)) > 0 Then Colors dest.Cells(1, i + 1), RGB(200, 200, 255) Colors dest.Cells(2, i + 1), RGB(255, 153, 0) End If Next i Set Names = New Collection On Error Resume Next For i = 1 To UBound(tbl, 1) For j = 3 To 6 If tbl(i, j) <> "" Then Names.Add tbl(i, j), CStr(tbl(i, j)) Next j Next i On Error GoTo 0 For i = 1 To Names.Count dest.Cells(i + 2, 1).Value = Names(i) Next i With dest.Range("A1:A2") .ClearFormats: .Merge: .Value = "الإســـم": .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter: .Font.Bold = True .Borders.LineStyle = xlContinuous: .Borders.color = RGB(0, 0, 255) .Interior.color = RGB(200, 200, 255) End With For i = 1 To lastRow - 3 For j = 1 To Names.Count If Not IsEmpty(dest.Cells(j + 2, 1)) Then name = Names(j) c = dest.Cells(1, i + 1).Value kay = "" For Each cell In WS.Range("J4:M" & WS.Cells(WS.Rows.Count, 10).End(xlUp).Row) If cell.Value = name And WS.Cells(cell.Row, 9).Value = c Then kay = (cell.Column - 9) & " مخزن" Exit For End If Next cell dest.Cells(j + 2, i + 1).Value = kay With dest.Range(dest.Cells(j + 2, 1), dest.Cells(j + 2, i + 1)) .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders(xlEdgeBottom).color = RGB(0, 0, 255) End With End If Next j Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Sub Colors(cell As Range, color As Long) With cell .Interior.color = color .Font.Bold = True .Borders(xlEdgeBottom).LineStyle = xlContinuous End With End Sub New.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته في الخلية A4 ضع احدى المعادلات التالية مع سحبها يسارا لغاية عمود L وسحبها أسفل لغاية الصف الدي يناسبك =IFERROR(INDEX('بيانات الطلاب'!A$3:A$100, SMALL(IF('بيانات الطلاب'!$B$3:$B$100=$B$1, ROW('بيانات الطلاب'!$B$3:$B$100)-ROW('بيانات الطلاب'!B$3)+1), ROW(1:1))), "") أو =IFERROR(INDEX('بيانات الطلاب'!A$3:A$100, AGGREGATE(15, 6, ROW('بيانات الطلاب'!$B$3:$B$100) -ROW('بيانات الطلاب'!B$3)+1/( 'بيانات الطلاب'!$B$3:$B$100=$B$1), ROW(1:1))), "") أو =FILTER('بيانات الطلاب'!A$3:A$100, 'بيانات الطلاب'!$B$3:$B$100 = $B$1) متابعة الطلاب.xlsx باستخدام الأكواد Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim d As Long, j As Long, clé As String, IRow As Long, col As Long Dim WS As Worksheet: Set WS = Worksheets("بيانات الطلاب") Dim F As Worksheet: Set F = Worksheets("متابعة الطلاب") If Not Intersect(Target, Me.Range("B1")) Is Nothing Then d = 4 clé = F.Range("B1").Value IRow = WS.Range("B3:B" & WS.Rows.Count).Find("*", _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Application.ScreenUpdating = False F.Range("A4:L" & F.Rows.Count).ClearContents For j = 3 To IRow If WS.Cells(j, 2).Value = clé Then For col = 1 To 12 F.Cells(d, col).Value = WS.Cells(j, col).Value Next col d = d + 1 End If Next j Application.ScreenUpdating = True End If End Sub متابعة الطلاب.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي الإسم =IFERROR(INDEX(A!B$3:B$1000, SMALL(IF(A!$A$3:$A$1000=$E$4, ROW(A!$A$3:$A$1000)-ROW(A!$A$3)+1), ROW()-5)), "") التشخيصي =IF(B6<>"", INDEX(A!C$3:AD$1000, MATCH(B6, A!B$3:B$1000, 0), MATCH($G$4, A!C$1:AD$1, 0)), "") التقويم =IF(B6<>"", INDEX(A!C$3:AD$1000, MATCH(B6, A!B$3:B$1000, 0), MATCH($G$4, A!C$1:AD$1, 0) + 1), "") A.xlsx

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

هل تقصد ان جدول البيانات 2/ النوع و الجهة موجودة مسبقا على الجدول فقط يتم تجميع الأرقام و الشرط: عدم تكرار نفس النوع والجهة معاً ادا كان هدا ما تقصده يكفي وضع المعادلة التالية في عمود H =IF(AND(G4<>"", F4<>""), IFERROR(SUMIFS(D4:D100, C4:C100, G4, B4:B100, F4), ""), "") أما إدا كنت ترغب باستخراج البيانات بالشكل الواضح في الصورة بدون وضع بيانات مسبقا استخدم الكود التالي في حدث ورقة 1 Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim rng As Range Set rng = Intersect(Target, Me.Range("B4:D" & Me.Rows.Count)) If Not rng Is Nothing Then TotalNonTri End If End Sub Sub TotalNonTri() Dim a() As Variant, i&, lig&, key As Variant, tmp As Variant Dim WS As Worksheet, d As Object, tbl As Variant, n As String Set d = CreateObject("Scripting.Dictionary") Set WS = Sheets("Sheet1") tbl = Range("B4:D" & Cells(Rows.Count, "B").End(xlUp).Row).Value Application.ScreenUpdating = False WS.Range("F4:H" & WS.Rows.Count).ClearContents For i = LBound(tbl, 1) To UBound(tbl, 1) If Not IsEmpty(tbl(i, 1)) And Not IsEmpty(tbl(i, 2)) Then n = tbl(i, 1) & "|" & tbl(i, 2) If d.Exists(n) Then d(n) = d(n) + tbl(i, 3) Else d(n) = tbl(i, 3) End If End If Next i ReDim a(1 To d.Count, 1 To 3) lig = 1 For Each key In d.Keys tmp = Split(key, "|") a(lig, 1) = tmp(0): a(lig, 2) = tmp(1): a(lig, 3) = d(key) lig = lig + 1 Next key With Range("F4").Resize(d.Count, UBound(a, 2)) .Value = a End With Application.ScreenUpdating = True End Sub Book1.xlsb

اخي @mahmoud nasr alhasany لا افهم مادا تقصده لقد تم الاجابة عن طلبك في اول مشاركة الان نتفاجئ ب حساب الأوزان النسبية واشياء اخرى لم تكن ضمن طلبك اول مرة فهدا لا علاقة له بموضوعنا وكدالك تفاديا لكثرة التعديلات سأنسحب ربما يستطيع أحد الإخوة مساعدتك

جرب هدا هل يناسبك توزيع فئات نقدية.xlsm