محمد هشام.

اخي انت واضع شرط انه لو قيمة الخلية قيمتها اصغر من 0 تظهر كلمة NEED PRODUCTION والخلية تتضمن -2 عادي =IF(E11>0, "There is stock", IF(E11<0, "NEED PRODUCTION", "critical no stock"))

وعليكم السلام ورحمة الله تعالى وبركاته تفضل جرب =IF(B22="","", INDEX(Feuil2!$G$4:G24, MATCH(B22, Feuil2!$D$4:D24, 0),1)) مع تغير Feuil2!$G$4:G24 باسم العمود المراد جلب بياناته في باقي الاعمدة او =IF(B22<>"",INDEX(Feuil2!E:E,AGGREGATE(15,6,ROW(Feuil2!E$4:E$24)/(Feuil2!$D$4:$D$24=B22),ROWS(C22:C22))),"") مع التغيير هنا بما يناسبك (Feuil2!E:E,AGGREGATE(15,6,ROW(Feuil2!E$4:E$24) =IFERROR(VLOOKUP(Feuil1!$B22,Feuil2!$D$4:$M$24,2,0),"") مع استبدال رقم 2 برقم العمود المراد جلب بياناته او =IF(B22="","",XLOOKUP(B22,Feuil2!$D$4:$D$24,Feuil2!$E$4:$E$24)) التقرير-اليومي 2022 مبرمج.xlsm

بيانات الموظفين.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Sub Recherche() Dim lastrow As Long, Col As Long Set wsdest = ThisWorkbook.Sheets("Feuil1") Set wsdata = ThisWorkbook.Sheets("Feuil2") lastrow = wsdata.Cells(Rows.Count, "C").End(xlUp).Row If Application.WorksheetFunction.CountA(wsdest.Range("AE7:AM7")) = 0 Then MsgBox "!!!المرجوا إدخال معايير الفلترة " & vbCrLf, vbInformation + vbOKOnly, " ! تنبيه" Exit Sub End If Application.ScreenUpdating = False ' إلغاء حماية الورقة wsdest.Unprotect "0000" If wsdest.AutoFilterMode Then wsdest.AutoFilterMode = False Col = wsdest.Cells(Rows.Count, "AE").End(xlUp).Row ' افراغ البيانات السابقة wsdest.Range("AE15:AM" & Col).Clear 'Contents 'نطاق الفلترة wsdata.Range("C27:K" & lastrow).AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=wsdest.Range("AE6:AM7"), _ CopyToRange:=wsdest.Range("AE14:AM14"), _ Unique:=True If Application.WorksheetFunction.CountA(wsdest.Range("AE15:AM15")) = 0 Then résultat = MsgBox("ليس هناك بيانات مطابقة لمعايير الفلترة الحالية", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه") End If On Error Resume Next ' اخفاء الصيغ wsdest.UsedRange.SpecialCells(xlCellTypeFormulas).FormulaHidden = True On Error GoTo 0 ' ارجاع الحماية لورقة العمل wsdest.Protect "0000" Application.ScreenUpdating = True End Sub التقرير-اليومي 2022 مبرمج.xlsm

تفضل اخي يمكنك اختيار ما يناسبك Option Explicit ' الغاء فلترة جميع اوراق العمل Sub Sup_tous_les_filtres() Dim WS As Worksheet For Each WS In Worksheets If WS.AutoFilterMode = True Then Debug.Print WS.Name WS.AutoFilterMode = False End If Next End Sub '**********او*********** Sub Sup_tous_les_filtres2() Dim WS As Worksheet For Each WS In Worksheets If WS.AutoFilterMode Then WS.AutoFilter.Range.AutoFilter End If Next End Sub '********تحديد تسلسل معين *********** Sub vSup_tous_les_filtres3() Dim i As Long Dim compteur As Long ' عدد اوراق العمل compteur = 100 ' من ورقة 1 الى 100 For i = 1 To compteur On Error Resume Next If Sheets(i).AutoFilterMode Then Sheets(i).AutoFilter.Range.AutoFilter On Error GoTo 0 End If Next i End Sub

=IF(I4="","",IF(I4="Pending","0",IF(I4>=200%,"4 months",IF(I4>=150%,"3.4 months",IF(I4>=130%,"3.3 months",IF(I4>=110%,"3.2 months",IF(I4>=105%,"3.1 months",IF(I4>=100%,"3 months",IF(I4>=90%,"2.7 months",IF(I4>=80%,"2.5 month",IF(I4>=70%,"2 month",IF(I4>=60%,"1.75 month",IF(I4>=50%,"1.5 months",IF(I4>=40%,"1.25 month",IF(I4>=30%,"1 month",IF(I4>=20%,"15 days",IF(I4>=10%,"7 days",IF(I4>=5%,"3 days",IF(I4>=1%,"Critical"))))))))))))))))))) =IF(I16="","",IF(I16>=200%,"4 months",IF(I16>=150%,"3.4 months",IF(I16>=130%,"3.3 months",IF(I16>=110%,"3.2 months",IF(I16>=105%,"3.1 months",IF(I16>=100%,"3 months",IF(I16>=90%,"2.7 months",IF(I16>=80%,"2.5 month",IF(I16>=70%,"2 month",IF(I16>=60%,"1.75 month",IF(I16>=50%,"1.5 months",IF(I16>=40%,"1.25 month",IF(I16>=30%,"1 month",IF(I16>=20%,"15 days",IF(I16>=10%,"7 days",IF(I16>=5%,"3 days",IF(I16>=1%,"Critical","Sales order")))))))))))))))))) Book1111111111.xlsx

TEST _Formula.xlsx

حل اخر Sub Recher_des_valeurs() Dim List1 As Range, List2 As Range, lr As Long Set wsdata = Sheets("Sheet1") lr = wsdata.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Application.ScreenUpdating = False With wsdata .Range("c2", Range("c" & Rows.Count).End(4)).ClearContents For Each List1 In .Range("a2:a" & .Cells(Application.Rows.Count, 2).End(xlUp).Row) Set List2 = .Columns(2).Find(List1.Value, , xlValues, xlPart) If Not List2 Is Nothing Then List1.Offset(, 2).Value = List2.Value Else List1.Offset(, 2).Value = "" If List1.Value = Empty Then List1.Offset(, 2).Value = List1.Offset(, 1).Value Next List1 End With '***(B) نقل النتيجة لعمود 'With wsdata ' .Range("c2:c" & lr).Cut .Range("b2:b" & lr) 'End With Application.ScreenUpdating = True End Sub ترتيب عمود بنفس قيم عمود اخر 3.xlsb

بعد ادن الاستاد الفاضل أ/محمد صالح ملاحظة سيتم التحقق من قيم القائمة 1 فقط في حالة وجود نفس القيمة في القائمة 2 سيتم جلب الاسم المقابل وفي حالة وجود فراغ في القائمة 1 يتم جلب قيمة القائمة 2 في حالة عدم وجودها يتم ترك الخلية فارغة ادا كنت قد استوعبت طلبك تفضل جرب وضع المعادلة في الخلية C2 مع سحبها للاسفل للتاكد من النتائج المتوقعة =IF(A2<>"",IFERROR(VLOOKUP(A2,B$2:$B$20,1,0),""),B2) في حالة الرغبة باستخراج النتائج في عمود B يمكنك استخدام الكود التالي Sub Insert_formula() Dim derligne As Long, K As String Dim wsdata As Worksheet: Set wsdata = Worksheets("Sheet1") derligne = wsdata.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row K = "=IF(A2<>"""",IFERROR(VLOOKUP(A2,B$2:$B$" & derligne & ",1,0),""""),B2)" Application.ScreenUpdating = False With Range("C2:C" & derligne) .Formula = [K] .Value = .Value End With For i = 2 To derligne Range("B" & i) = Range("C" & i) Next i Range("C2:C" & derligne).ClearContents Application.ScreenUpdating = True End Sub 2ترتيب عمود بنفس قيم عمود اخر.xlsm

ربما عليك اولا مطابقة البيانات في عمود الكلاستر مع الغاء دمج الخلايا لتتمكن من سحب المعادلة للاسفل

وعليكم السلام ورحمة الله تعالى وبركاته لم استوعب الطلب جيدا لاكن على العموم تفضل جرب ووافينا بالنتيجة Sub Unique_Stores() Dim rng As Range, cRng As Range Dim cell As Range, Lastrow As Long Dim wsDest As Variant, s As String Dim cUnique As Collection Set WSData = ThisWorkbook.Sheets("aaa") 'عمود الفلترة Set rng = WSData.Range("L2:L" & WSData.Cells(WSData.Rows.Count, "L").End(xlUp).Row) Set cUnique = New Collection Application.ScreenUpdating = False Application.DisplayAlerts = False Application.CopyObjectsWithCells = False ' حدف الاوراق السابقة For Each ws In Sheets If ws.Name <> WSData.Name Then ws.Delete Next On Error Resume Next For Each cell In rng.Cells cUnique.Add cell.Value, CStr(cell.Value) Next cell On Error GoTo 0 ' انشاء اوراق جديدة For Each wsDest In cUnique s = wsDest Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsDest ActiveSheet.DisplayRightToLeft = True With WSData Lastrow = .Cells(.Rows.Count, "L").End(xlUp).Row .Range("A2").AutoFilter field:=12, Criteria1:=wsDest ' النطاق المنسوخ Set cRng = .Range("A1:S" & Lastrow) cRng.Copy Sheets(s).Range("A2") .Select .[A2].AutoFilter End With Next wsDest '''''''''تنسيق الاوراق الجديدة ''''''' For Each wsCopy In ThisWorkbook.Worksheets If wsCopy.Name <> WSData.Name Then 'خلية اسم المخزن Set rng = wsCopy.[G1] rng = "المخزن" & "" & wsCopy.Name With rng .Font.Name = "Algerian": .Font.Size = 20: .Font.Color = vbBlue End With ' تنسيق الاعمدة For i = 1 To 19 wsCopy.Columns(i).ColumnWidth = WSData.Columns(i).ColumnWidth wsCopy.Rows(i).RowHeight = WSData.Rows(i).RowHeight ' التحقق من خطأ تنسيق الخلايا Application.ErrorCheckingOptions.BackgroundChecking = False Next '************************************************** ' لتسمية الاوراق باسم المخزن قم بتفعيل السطر التالي ' wsCopy.Name = rng '************************************************* End If Next wsCopy WSData.Activate Application.ScreenUpdating = True Application.CopyObjectsWithCells = True End Sub ترحيل البيانات حسب اسم المخزن.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Private Sub CommandButton1_Click() With Sheets("main") LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row For J = 2 To LastRow If TextBox1.Text = .Cells(J, 1) Then Me.ListBox1.AddItem Cells(J, 2) 'Me.TextBox1 = Empty End If Next End With End Sub '******************************* Private Sub CommandButton2_Click() ligne = Me.ListBox1.ListIndex If ligne <> -1 Then Me.ListBox1.RemoveItem ligne End Sub 20231013 test.xlsm

Me.TextBox52.Value = Evaluate("SUM(0+(O10:O" & Cells(Rows.Count, "O").End(xlUp).row & "<>""""))") مني 3.xlsm

Private Sub CommandButton14_Click() Dim ColNum As Long, MyValue As String, Col As Range MyValue = Me.TextBox50 ColNum = 15 If Me.TextBox50 = "" Then: Exit Sub Set Col = ActiveSheet.Columns(ColNum).Find(what:=MyValue, LookIn:=xlValues, lookat:=xlWhole) If Not Col Is Nothing Then Me.TextBox51 = WorksheetFunction.CountIf(Columns(ColNum), MyValue) Else MsgBox "غير موجود" Me.TextBox50 = Empty End If End Sub مني 2 (2).xlsm

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

تفضل جرب ووافينا بالنتيجة مستخلصات هيكل2023 الجنوبية 3.xlsm

ممكن المزيد من التوضيح بخصوص التاريخ هل تقصد ادراج تاريخ انشاء الشيت اي تاريخ اليوم او مادا لنفترض اننا قمنا بانشاء ورقة جاري 2 ما هو التاريخ المتوقع في الخلية k10 و k11

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

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Sub Recher_des_valeurs() Dim MyRng As Range, MyCell As Range Set WSdata = Sheets("Sheet1") Application.ScreenUpdating = False With WSdata .Range("E3", Range("E" & Rows.Count).End(4)).ClearContents For Each MyRng In .Range("B3:B" & .Cells(Application.Rows.Count, 2).End(xlUp).Row) Set MyCell = .Columns(9).Find(MyRng.Value, , xlValues, xlPart) If Not MyCell Is Nothing Then MyRng.Offset(, 3).Value = MyCell.Offset(, 3).Value Else MyRng.Offset(, 3).Value = 0 Next MyRng End With Application.ScreenUpdating = True End Sub البحث 2.xlsb

ممكن صورة للخطا الدي يواجهك لقد تمت تجربت الملف على اكثر من جهاز لم تصادفني ادنى مشكلة في التنفيد ربما عليك مراجعة اعدادات الماكرو على جهازك لتتاكد من دالك اليك الرابط التالي https://streamable.com/o6di16 مستخلصات هيكل2023 الجنوبية 2.xlsm

اليك حل اخر باستخدام Combobox اظافة الى الحل الاول يمكنك اختيار ما يناسبك Private Sub ComboBox1_GotFocus() Dim wsdata As Worksheet: Set wsdata = Sheet1 Set d = CreateObject("Scripting.Dictionary") For Each c In wsdata.Range("B3", wsdata.Cells(Rows.Count, "B").End(xlUp)) If Not d.Exists(c.Value) Then d(c.Value) = "" Next c MyRng = d.keys tri MyRng, LBound(MyRng), UBound(MyRng) Me.ComboBox1.List = MyRng End Sub '*************************************** Private Sub ComboBox1_Change() Dim WS As Worksheet: Set WS = Sheet1 Set Tbl = WS.ListObjects("Data") Réf = ComboBox1 Tbl.Range.AutoFilter Field:=2, Criteria1:=Réf If Me.ComboBox1 = Empty Then Tbl.ShowAutoFilter = False End Sub وفي موديول Sub tri(a, gauc, droi) 'ترتيب ابجدي Réf = a((gauc + droi) \ 2) g = gauc: d = droi Do Do While a(g) < Réf: g = g + 1: Loop Do While Réf < a(d): d = d - 1: Loop If g <= d Then MyRng = a(g): a(g) = a(d): a(d) = MyRng g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call tri(a, g, droi) If gauc < d Then Call tri(a, gauc, d) End Sub '********* ' الغاء الفلترة Public Sub Reset_filter() Dim WS As Worksheet: Set WS = Sheet1 Sheets("Sheet1").TextBox1.Text = "": Sheets("Sheet1").ComboBox1.Text = "" Set Tbl = WS.ListObjects("Data") Tbl.Range.AutoFilter Field:=2 Tbl.ShowAutoFilter = False End Sub test_aziz_3.xlsb

ممكن وضع الكود بهدا الشكل لتستطيع الفلترة باي جزء من الاسم Private Sub TextBox1_Change() Dim WS As Worksheet: Set WS = Sheet1 Set Tbl = WS.ListObjects(1) Réf = "*" & Replace(Me.TextBox1, " ", "*") & "*" Tbl.Range.AutoFilter Field:=2, Criteria1:=Réf If Me.TextBox1 = Empty Then Tbl.ShowAutoFilter = False End Sub

الملف خالي من الاكواد مع عدم دكر عمود او معيار الفلترة

اخي سعد ببساطة لتتمكن من تنفيد المطلوب ما عليك هو وضع هده الاكواد داخل OptionButton لتنشيط ورقة العمل الهدف واستبدال اسم ورقة العمل في اكواد اليوزرفورم للتعامل دائما مع ActiveSheet Private Sub OptionButton1_Click() Sheets(CStr(OptionButton1.Caption)).Activate End sub Private Sub OptionButton2_Click() Sheets(CStr(OptionButton2.Caption)).Activate End sub Private Sub OptionButton3_Click() Sheets(CStr(OptionButton3.Caption)).Activate End sub مني 2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته فقط اجعل الكود هكدا Sheets("المقبوضات").Range("A2:L2000").AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Range("A1:D2"), CopyToRange:=Range("A4:H4"), Unique:=False وقم بجعل Criteria الخاصة بمعايير الفلترة بهدا الشكل GES1 - Copy.xlsm