محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته تفضل جرب الصيغة التالية =IFERROR(IF(B8<>"";INDEX(price_list!$J$5:$J$10000;MATCH(2;1/(price_list!$E$5:$E$10000=B8)/(price_list!$A$5:$A$10000<=$B$4)));"");"") اخر سعر =INDEX(price_list!$J$5:$J$10000;MATCH(2;1/(price_list!$E$5:$E$10000=B8))) اكبر سعر =MAX(IF(price_list!$A$5:$A$10000<=$B$4;IF(price_list!$E$5:$E$10000=B8;price_list!$J$5:$J$10000))) price list officena - 2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاستاد المحترم @محمد حسن المحمد تفضل جرب اخي Sub Total_amount() Dim WS As Worksheet, Dest As Worksheet: Set WS = Sheets("Sheet1"): Set Dest = Sheets("التجميع بدون تكرار") a = WS.Range("B1").CurrentRegion.Value Dim c() ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2)) Cpt = 1 Set mondico = CreateObject("Scripting.Dictionary") Application.ScreenUpdating = False For i = 1 To UBound(a) temp = a(i, 1) & a(i, 2) If Not mondico.exists(temp) Then mondico.Add temp, "" For k = 1 To UBound(a, 2) - 1: c(Cpt, k) = a(i, k): Next k c(Cpt, k) = c(Cpt, k) + a(i, k) Cpt = Cpt + 1 Else j = Application.Match(temp, mondico.keys, 0) col = UBound(a, 2) c(j, col) = c(j, col) + a(i, col) End If Dest.[B1:D1000] = Empty Next Dest.[B1].Resize(mondico.Count, UBound(a, 2)) = c End Sub كود تجميع .xlsb

بما انك لم تقم بارفاق الملف لنتمكن من تحديد النطاق المرغوب نسخه اليك مثال للمطلوب يمكنك تعديله بما يناسبك Sub Copy_My_Data() Dim Cpt&, lCol&, lRow& Dim WSdata As Worksheet, Dest As Worksheet, MyRng As Range, r As String Dim WS1 As Workbook, WS2 As Workbook :Set WS1 = ThisWorkbook With Application .ScreenUpdating = False r = InputBox("قم بإدخال اسم المصنف المرغوب جلب البيانات منه", "Choose file name") On Error Resume Next If r = False And r <> 0 Then Exit Sub If r = 0 Then Set WS2 = Workbooks("transactionTable.xls") 'اول نسخة من المصنف = 0 Else Set WS2 = Workbooks("transactionTable" & " (" & r & ")" & ".xls") ' تعريف المصنف من خلال الرقم End If If Not WS2 Is Nothing Then Set WSdata = WS2.Sheets("Sheet1") ' transactionTable اسم الشيت المنسوخ منه lRow = WSdata.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row lCol = WSdata.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column ' قم بتعديل النطاق المنسوخ بما يناسبك Set MyRng = WSdata. _ Range("A2", WSdata.Cells(lRow, lCol)) Set Dest = WS1.Sheets("Sheet1") ' b2024' اسم شيت اللصق على ملف Cpt = Dest.Cells(Dest.Rows.Count, "A").End(xlUp).Offset(1).Row MyRng.Copy Dest.Range("A" & Cpt).PasteSpecial Paste:=xlPasteValues Application.Goto Dest.[A1], True .CutCopyMode = False .ScreenUpdating = True MsgBox _ "تم نسخ البيانات بنجاح من" & Chr(10) & Chr(10) & WS2.Name, vbInformation Else MsgBox (" لم يتم العثور على المصنف ") & r, 48, "خطأ" On Error GoTo 0 End If End With End Sub بالتوفيق...... test 2.rar

1) أخي هذا موضوع لا علاقة له بالسؤال المرفق في اول مشاركة. 2) حاول إرفاق نسخة من الملفين معا مع تحديد طريقة النسخ المتوقعة. والنطاق المطلوب ترحيله .وان شاء الله سوف نحاول مساعدتك.

قم باستبدال If TblInv(i, 1) = CB_Pièce Then الى If TblInv(i, 1) = CB_Pièce.Text Then

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي يمكنك اختيار ما يناسبك Sub TEST1() Dim arr(1 To 3) As String ' المسار الافتراضي للمصنف المفتوح arr(1) = ThisWorkbook.path & "\" arr(2) = InputBox("Type in the name of the file you want to open", "Choose file name") arr(3) = Dir(arr(1) & "transactionTable" & " (" & arr(2) & ")" & ".xls*") If arr(3) <> "" Then Set Clé = Workbooks.Open(arr(1) & arr(3)) Else MsgBox ("Workbook Not Found"), vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal End If End Sub '************** ' تنشيط ورقة عمل على نفس المصنف Sub test2() Dim shname As String, x_Name As String Do Until WorksheetExists(x_Name) shname = InputBox("Type in the name of the Sheet you want to Activate") x_Name = "transactionTable" & " (" & shname & ")" If Not WorksheetExists(x_Name) Then MsgBox x_Name & " Doesn't exist!", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal: Exit Sub Loop Sheets(x_Name).Activate End Sub Function WorksheetExists(WSName As String) As Boolean On Error Resume Next WorksheetExists = Worksheets(WSName).Name = WSName On Error GoTo 0 End Function '****************** Sub test3() Dim arr(1 To 3) As String, file_name As String ' قم بتحديد المسار الخاص بك arr(1) = "C:\Users\hicham\OneDrive\Bureau\test" arr(2) = InputBox("Type in the name of the file you want to open", "Choose file name") file_name = "transactionTable" & " (" & arr(2) & ")" arr(3) = arr(1) & "\" & file_name & ".xls" If Dir(arr(3)) = "" Then MsgBox ("Workbook Not Found"), vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal Exit Sub End If Workbooks.Open filename:=arr(3) End Sub '**************************بطرق اخرى ********************* Sub test4() Dim arr(1 To 2) As String, WS As Workbook arr(1) = InputBox("Type in the name of the file you want to open", "Choose file name") arr(2) = ThisWorkbook.path & Application.PathSeparator & "transactionTable" & " (" & arr(1) & ")" & ".xls" If Not Dir(arr(2), vbDirectory) = vbNullString Then Set WS = Workbooks.Open(arr(2)) Else MsgBox arr(2) & Chr(10) & "Workbook Not Found", 48, "Not Found" End If End Sub '***************** Sub test5() Dim arr(1 To 2) As String, WS As Workbook arr(1) = InputBox("Type in the name of the file you want to open", "Choose file name") arr(2) = ThisWorkbook.path & Application.PathSeparator & "transactionTable" & " (" & arr(1) & ")" & ".xls" If Dir(arr(2)) = "" Then MsgBox ("Workbook Not Found"), vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal Exit Sub End If Set WS = Workbooks.Open(arr(2)) End Sub test.rar

العفو اخي يسعدنا اننا استطعنا مساعدتك

اخي ربما يتعين عليك وضع حماية لورقة العمل لديك لمنع اظهار الاعمدة او اخفائها بدون ادخال كلمة المرور جرب هدا الملف باسوورد 1234 إخفاء اعمدة وصفوف برقم سري.xlsb

Public Property Get WS() As Worksheet: Set WS = Feuil1 End Property Sub Hide_Columns() col = "F:G" On Error Resume Next WS.Columns(col).Hidden = True msg = InputBox("أدخل كلمة المرور", "كلمة المرور") If msg = "1234" Then WS.Columns(col).Hidden = False Else If MsgBox("كلمة المرور غير صحيحة، حاول مرة أخرى", Yes Or No, "كلمة مرور خاطئة") = Yes Then WS.Columns(col).Hidden = True On Error GoTo 0 End If End If End Sub '************************** Sub Hide_Rows() Xrows = "13:14" On Error Resume Next WS.Rows(Xrows).Hidden = True msg = InputBox("أدخل كلمة المرور", "كلمة المرور") If msg = "1234" Then WS.Rows(Xrows).Hidden = False Else If MsgBox("كلمة المرور غير صحيحة، حاول مرة أخرى", Yes Or No, "كلمة مرور خاطئة") = Yes Then WS.Rows(Xrows).Hidden = True On Error GoTo 0 End If End If End Sub إخفاء اعمدة وصفوف برقم سري.xlsb

مرحبا اساتذتنا الكرام يسرني المشاركة معكم في ايجاد حل للمطلوب رغم انني لم استوعب الفكرة جيدا وكنت قد صرفت النظر عن المشاركة في الموضوع لاكن بعد معاينة النتيجة المستخرجة على ملف الاستاد @AbuuAhmed الدي نكن له كل الاحترام والتقدير. اليك اخي هده المساهمة البسيطة على قدر ما استطعت فهمه لحد الساعة مع تغيير اسم الورقة المظافة من مصفوفة الى Test 🫣🫣 Sub test1() Dim wb As Workbook, WSdata As Worksheet, dest As Worksheet, lRow As Long, lCol As Long Set wb = ThisWorkbook: Set WSdata = wb.Sheets("الفواتير"): Set dest = wb.Sheets("Test") A = WSdata.Range("A2:I" & WSdata.[D65000].End(xlUp).Row) With Application .ScreenUpdating = False With dest Intersect(.Range(.Rows(2), .UsedRange.Rows(.UsedRange.Rows.Count)), .Range("A:I")).ClearContents End With Dim c(): ReDim c(1 To UBound(A, 1), 1 To 9) Cpt = 0 Set mondico = CreateObject("Scripting.Dictionary") For I = 1 To UBound(A) On Error Resume Next clé = A(I, 4) & A(I, 8) If Not mondico.exists(clé) Then Cpt = Cpt + 1: mondico.Add clé, Cpt: c(Cpt, 1) = clé: F = Cpt Else F = mondico.Item(clé) End If c(F, 1) = A(I, 1): c(F, 2) = A(I, 2): c(F, 3) = A(I, 3): c(F, 4) = A(I, 4): c(F, 5) = c(F, 5) + A(I, 5) c(F, 6) = c(F, 6) + A(I, 6): c(F, 7) = c(F, 7) + A(I, 7): c(F, 8) = A(I, 8): c(F, 9) = A(I, 9) Next dest.[a3].Resize(mondico.Count, UBound(c, 2)) = c lRow = dest.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row With dest Union(dest.Range("A3:A" & lRow), dest.Range("F3:F" & lRow)).NumberFormat = "#,##0;- #,##0;""-""??" dest.Range("C3:C" & lRow).NumberFormat = "dddd dd-mm-yyyy" dest.Range("E3:E" & lRow).NumberFormat = "#,##0.0;- #,##0.0;""-""??" If dest.ListObjects.Count <> 0 Then Exit Sub lCol = .Cells(3, dest.Columns.Count).End(xlToLeft).Column dest.ListObjects.Add(xlSrcRange, .Range(dest.Cells(3, 1), .Cells(lRow, lCol)), , xlYes).Name = "Table1" .ListObjects("Table1").ShowAutoFilterDropDown = False End With On Error GoTo 0 .ScreenUpdating = True End With End Sub تجربة1.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته لاظافة صور جديدة او استبدالها يجب عليك اتباع الخطوات التالية 1) اظهار الصور المخفية بواسطة الكود المرفق مع الملف 2) اعادة تسمية الصور على حسب احتياجاتك وقد تم شرح الطريقة في الرابط التالي https://streamable.com/ghw7yy اما بخصوص اخر سؤال المعادلة الموجودة في الخلية F3 =IF(D3="";"";VLOOKUP(D3;range1;3;0)) تقوم فقط بجلب اسم الصورة من شيت 2 العمود D المقابلة لقيمة الخلية D3 ورقة 1 ليس بتحويل الصورة الى نص وفي حدث ورقة 1 الكود التالي يقوم باخفاء جميع الصور والبقاء على الصورة الهدف بشرط قيمة الخلية F3 Private Sub Worksheet_Calculate() Dim oPic As Picture Me.Pictures.Visible = False With Range("F3") For Each oPic In Me.Pictures If oPic.Name = .Text Then oPic.Visible = True oPic.Top = .Top oPic.Left = .Left Exit For End If Next oPic End With End Sub البيانات مع الصورة 2.xls

وعليكم السلام ورحمة الله تعالى وبركاته ربما هدا ما تقصد Sub test() Dim i As Long, lRow As Long lRow = Cells(Rows.Count, "A").End(xlUp).Row With Application .ScreenUpdating = False For i = lRow To 2 Step -1 If IsError(.Match(0, Range("A" & i & ":D" & i), 0)) Then Rows(i).EntireRow.Delete End If Next .ScreenUpdating = True End With End Sub ملف.xlsb

ملاحظة : في حالة قمت بحدف عناوين الاعمدة سيتم نسخ البانات بعد اخر خلية فارغة في عمود C ولتثبيت اللصق في الصف 22 ما عليك هو تعديل الصفوف التالية For j = 22 To ligne If UCase(WS.Cells(j, col)) = r Then Set Rng = WS.Range(WS.Cells(j, 3), WS.Cells(j, 30)) If dest.[C22] = Empty Then dest.[C22].Resize(1, 28).Value = Rng.Value Else: dest.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Resize(1, 28).Value = Rng.Value End If End If ''''''''''''''''''''''''''''''او'''''''''''''''''''''''''''' Dim dlr As Long For j = 22 To ligne If UCase(WS.Cells(j, col)) = r Then dlr = dest.Cells(Rows.Count, "C").End(xlUp).Row If dlr < 21 Then dlr = 21 Set Rng = WS.Range(WS.Cells(j, 3), WS.Cells(j, 30)) dest.Range("C" & dlr).Offset(1).Resize(1, 28).Value = Rng.Value End If Next j

وعليكم السلام ورحمة الله تعالى وبركاته Sub test() Dim wb As Workbook, WS As Worksheet, dest As Worksheet Set wb = ThisWorkbook: Set WS = wb.Sheets("Sheet1"): Set dest = wb.Sheets("Sheet2") Dim j&, col&, ligne&, r As String Dim Rng As Range: col = 12: r = dest.[B19] ligne = WS.Cells(Rows.Count, col).End(xlUp).Row With Application .ScreenUpdating = False dest.Range("C22", Range("AD" & Rows.Count).End(4)).ClearContents For j = 22 To ligne If UCase(WS.Cells(j, col)) = r Then Set Rng = WS.Range(WS.Cells(j, 3), WS.Cells(j, 30)) dest.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Resize(1, 28).Value = Rng.Value End If Next j If Application.WorksheetFunction.CountA(dest.Range("C22:AD22")) = 0 Then MsgBox "غير موجود" & " / " & r, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه" End If .ScreenUpdating = True End With End Sub تجربة 2.rar

تمام لاستخراج الرموز بدون تكرار في ورقة ادخال البيانات الخلية P18 ضع المعادلة التالية مع سحبها للاسفل =IFERROR(INDEX($L$18:$L$200; MATCH(0; IF(ISBLANK($L$18:$L$200); 1; COUNTIF(P17:$P$17; $L$18:$L$200)); 0));"") مع تسمية النطاق بالشكل التالي وليكن مثلا Clé =OFFSET('ادخال البيانات'!$P$18;0;0;COUNT(IF('ادخال البيانات'!$P$18:$P$10000="";"";1));1) ولجلب البيانات استخدم الكود التالي Sub Search() Dim WSdata As Worksheet: Dim WSEntry As Worksheet: Set WSdata = Feuil1: Set WSEntry = Feuil2 Dim Clé As String, all As String, lr As Long, F&, Col& Dim a As Range, b As Range, rngCell As Range With Application .ScreenUpdating = False .Calculation = xlCalculationManual lr = WSdata.Cells(WSdata.Rows.Count, "C").End(xlUp).Row Clé = WSEntry.[G1]: all = "الكل" WSEntry.Range("A4:F500").ClearContents For Col = 4 To lr If WSdata.Cells(Col, "H") Like Clé Then Set a = WSdata.Range(WSdata.Cells(Col, 3), WSdata.Cells(Col, 8)) WSEntry.Cells(Rows.Count, "a").End(xlUp).Offset(1, 0).Resize(, 6).Value = a.Value End If If Clé Like all Then Set b = WSdata.Range(WSdata.Cells(Col, 3), WSdata.Cells(Col, 8)) WSEntry.Cells(Rows.Count, "a").End(xlUp).Offset(1, 0).Resize(, 6).Value = b.Value End If Next Col F = WSEntry.Range("A:H").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rngCell = WSEntry.Range("A4 :H" & F) WSEntry.Range("A4:H500").Borders.LineStyle = xlNone For Each c In rngCell.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next If Application.WorksheetFunction.CountA(WSEntry.Range("A4:H5")) = 0 Then MsgBox "ليس هناك بيانات مطابقة لمعايير الفلترة الحالية" & " / " & Clé, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه" End If .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub وفي حدث ورقة ادخال البيانات Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Target.Worksheet.Range("G1")) Is Nothing Then If Target.Cells.Value = " " Or IsEmpty(Target) Then Exit Sub Call Search Application.EnableEvents = True End If On Error GoTo 0 End Sub ترحيل بيانات 7.xlsm

مع بعض التعديلات البسيطة Sub Find_And_copy() ' to Update 06 / 01 / 2024 Dim c As Range: Dim Col As Range Dim r As Range: Dim Rng As Range Dim WS As String: Dim j As Long Dim lastrow As Long: Dim MyData As Worksheet: Set MyData = Feuil2 On Error Resume Next If MyData.[H2] = "" Then: MsgBox "المرجوا إدخال تاريخ الغياب", vbInformation, "admin": Exit Sub lastrow = MyData.Columns("G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row If WorksheetFunction.CountA(MyData.Range("G4:G" & lastrow + 1)) = 0 Then MsgBox "يرجى ملئ بيانات" & " : " & [G3], vbExclamation: Exit Sub If WorksheetFunction.CountA(MyData.Range("H4:H" & lastrow + 1)) = 0 Then MsgBox "يرجى ملئ بيانات" & " : " & [H3], vbExclamation: Exit Sub For j = 4 To lastrow If MyData.Range("G" & j) <> "" Then: WS = MyData.Cells(j, "G") Set MyDest = Worksheets(WS) With Application .ScreenUpdating = False With MyDest For Each r In MyDest.Range("A5", .Cells(Rows.Count, 1).End(xlUp)) Set Rng = MyData.Range("A:A").Find(r.Value, , xlValues, xlWhole) If Not Rng Is Nothing Then For Each c In Application.Intersect(MyData.UsedRange, MyData.[H2]) If Len(c.Value) > 0 And Application.CountA(c.EntireColumn) > 1 Then Set Col = MyDest.Rows(3).Find(What:=c.Value, LookIn:=xlValues, LookAt:=xlWhole) If Col Is Nothing Then: MsgBox "المرجوا التحقق من تاريخ الإدخال" & " : " & MyData.[H2].Value, vbInformation, "تعليمات": Exit Sub If Not Col Is Nothing And Rng.Offset(, 6).Value = MyDest.Name Then MyDest.Cells(r.Row, Col.Column).Value = Rng.Offset(, 7).Value End If End If Next c End If Next End With .ScreenUpdating = True End With Next j On Error GoTo 0 MyData.Range("G4:H" & lastrow + 1).ClearContents: [H2] = Empty MsgBox "تم ترحيل البيانات بنجاح ", vbInformation, "admin" End Sub ترحيل بيانات 6.xlsm

العفو أخي الكريم يسعدنا أننا استطعنا مساعدتك

Set wsdata = Feuil2 ملاحظة: إذا كنت تقوم بنسخ الكود فقط إلى ملف الأصلي. حاول تعديل أسماء أوراق العمل لديك لتتطابق مع الأسماء الموجودة في القائمة المنسدلة في عمود G لأنها غير مطابقة وتم إصلاحها في الملفات السابقة. مجرد وجود اختلاف في حرف أو فراغ معين. قد يسبب عدم اشتغال الكود معك بشكل جيد ترحيل بيانات5.xlsm

أرفق ملفك الأصلي مع صورة توضح الخطأ الذي يظهر معك هل قمت بتجربة الملف الذي رفعت لك في آخر مشاركة ؟

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

جرب هدا الحل هل يناسبك هيثم -2.xlsx

طلبك غير واضح المرجوا إرفاق عينة للنتائج المتوقعة

نعم أخي ربما لم تلاحظ التغيير فقط اجعل كلمة وارد داخل المعادلة بهذا الشكل *وارد*

سؤالك غير واضح لاكن ربما هدا ما تقصد =IFERROR(1/(1/MAXIFS($G$3:G1000;$A$3:$A1000;"="&J12;$E$3:$E1000;"="&"*وارد*"));"")

بما انك لم تقم بنشر الكود بالكامل لنتمكن من تحديد عنصر التغيير لديك و على حسب تخميني انك تستخدم يوزرفورم اليك نمودج للحل يمكنك تطويعه على حسب احتياجاتك وكما سبق الدكر انه يوجد صعوبة لانشاء الكود الصحيح ما دمت لم تقم برفع ملف يتضمن طلبك بشكل اوضح لنفترض انك تقوم باختبار البيانات عن طريق Combobox1 '''''''''''''''طريقة رقم 1'''''''''''''''''''' Private Sub ComboBox1_Change() For bgg = 1 To 17 If Application.WorksheetFunction.VLookup(Me.ComboBox1.Text, Range("B:E"), 4, 0) = "نعم" Then Me("CheckBox" & bgg).Caption = True Else Me("CheckBox" & bgg).Caption = False End If Next End Sub ''''''''''''''طريقة رقم 2'''''''''''''''''''' 'Private Sub ComboBox1_Change() 'Dim bgg As Control, réf As String, col As Range 'Set WS = Sheet1: Set col = WS.Range("B2:E" & WS.[B65000].End(xlUp).Row) 'For Each bgg In Me.Controls 'réf = Me.ComboBox1.Text 'If Application.WorksheetFunction.VLookup(réf, col, 4, False) = "نعم" Then ' If TypeName(bgg) = "CheckBox" Then bgg.Caption = True ' Else ' If TypeName(bgg) = "CheckBox" Then bgg.Caption = False 'End If 'Next 'End Sub ''''''''''''''طريقة رقم 3'''''''''''''''''''' 'For Each bgg In UserForm1.Controls 'If TypeName(bgg) = "CheckBox" Then 'If Application.WorksheetFunction.VLookup(Me.ComboBox1.Text, Range("B:E"), 4, 0) = "نعم" Then bgg.Caption = True Else bgg.Caption = False 'End If 'Next bgg '''تحديد العناصر''''''طريقة رقم 4'''''''''''''''''''' 'Dim bgg As Control 'For Each bgg In Me.Controls 'If Application.WorksheetFunction.VLookup(Me.ComboBox1.Text, Range("B:E"), 2, 0) = "نعم" Then ' If TypeName(bgg) = "CheckBox" Then bgg.Value = True ' Else ' If TypeName(bgg) = "CheckBox" Then bgg.Value = False 'End If 'Next '''التحقق مع تلوين القيمة ''''''طريقة رقم 5'''''''''''''''''''' Private Sub ComboBox1_Change() Dim LR& Set ws = Sheet1 With ws LR = .Cells(.Rows.Count, "B").End(xlUp).Row For bgg = 1 To 17 If Application.WorksheetFunction.VLookup(Me.ComboBox1.Text, Range("B:E"), 4, 0) = "نعم" Then Me("CheckBox" & bgg).Caption = True Else Me("CheckBox" & bgg).Caption = False End If Next For i = 2 To LR .Range("E" & i).Interior.Color = xlNone If .Range("B" & i).Value = Me.ComboBox1.Value And .Range("E" & i).Value = "نعم" Then .Range("E" & i).Interior.Color = vbYellow End If Next i End With End Sub اليك ملف حاولت تنفيد الفكرة عليه لتتمكن من تعديلها بما يناسبك CONTROLS F_VLookup.xlsm