محمد هشام.

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

وعليكم السلام ورحمة الله تعالى وبركاته Sub CreateSheets() Dim mydata As Worksheet: Set mydata = ThisWorkbook.Sheets("Sheet1") Dim MyRng As Range, RngCopy As Range, Sh As Collection Dim cell As Range, DerLig As Long Dim wsDest As Variant, s As String Set MyRng = mydata.Range("C6:C" & mydata.Cells(mydata.Rows.Count, "C").End(xlUp).Row) Set Sh = New Collection With Application .ScreenUpdating = False .DisplayAlerts = False End With For Each WS In Sheets If WS.Name <> mydata.Name Then WS.Delete Next On Error Resume Next For Each cell In MyRng.Cells Sh.Add cell.Value, CStr(cell.Value) Next cell On Error GoTo 0 For Each wsDest In Sh s = wsDest Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsDest ActiveSheet.DisplayRightToLeft = True With mydata DerLig = .Cells(.Rows.Count, "C").End(xlUp).Row .Range("A5").AutoFilter field:=3, Criteria1:=wsDest Set RngCopy = .Range("A5:C" & DerLig) RngCopy.Copy Sheets(s).Range("A5") .Select .[A5].AutoFilter End With Next wsDest For Each wscopy In ThisWorkbook.Worksheets If wscopy.Name <> mydata.Name Then For i = 1 To 3 wscopy.Cells.EntireRow.AutoFit wscopy.Columns(i).ColumnWidth = mydata.Columns(i).ColumnWidth wscopy.Rows("5:5").RowHeight = mydata.Rows("5:5").RowHeight wscopy.Columns("B:B").ColumnWidth = 70 wscopy.Activate With ActiveWindow .SplitRow = 5 .SplitColumn = 0 .FreezePanes = True End With Next End If Next wscopy mydata.Activate With Application .ScreenUpdating = True .DisplayAlerts = True End With End Sub اسلاميات 2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته الاكواد ربما لملف آخر وانت تحاول ضبطها على ملفك ربما يمكننا مساعدتك عند الإجابة على الإستفسارات التالية: بالنسبة للترحيل الملف عليه ارتباط من ملف آخر لبيانات آمين المستودع والمستلم ورئيس القسم. يمكنك تحديد عناوين الخلايا لحين كتابة الكود ثم وضع المعادلات الخاصة بك . B32 D32 G32............ ....... إضافة انك لابد أن توضح هل يتم تكرار نفس البيانات على طول الفاتورة او نسخها في اول صف فقط وكذلك التاريخ هل عمود التسلسل في شيت تقرير الصرف يتم نسخه من الفاتورة أم إضافة تسلسل جديد بالنسبة للاستعلام ماهو شرط البحث هل رقم الصنف مثلا......

يتم دالك بسبب نسخ قيمة Textbox مكان المعادلة هناك 2 حلول اما استبدال الكود بكود يتوافق مع شكل وتصميم الملف او تعديله بالطريقة التالية وهي الاستغناء عن وضع المعادلة يدويا وتعويضها بواسطة الاكواد على النحو التالي Private Sub CommandButton3_Click() Dim DerLig As Long, X As Long Dim WSData As Worksheet: Set WSData = ActiveSheet DerLig = WSData.Range("C" & WSData.Rows.Count).End(xlUp).row Application.ScreenUpdating = False If Me.TextBox1.Value = Empty Then: Exit Sub X = Application.Match(Val(TextBox1.Value), WSData.Columns("C"), 0) If Not IsError(X) Then For i = 2 To 18 WSData.Cells(X, i + 2).Value = Controls("TextBox" & i).Value WSData.Cells(X, i + 2).Value = WSData.Cells(X, i + 2).Value Next i End If For r = 1 To 18 Me("Textbox" & r) = "" Next r WSData.Range("C10").Value = 1 WSData.Range("C10:C" & DerLig).DataSeries , xlDataSeriesLinear ' وضع المعادلة WSData.Range("P10:P" & DerLig).Formula = "=IF(N10="""","""",""(""& O10&"" / ""&N10&"")"")" With WSData.Range("P10:P" & DerLig) .Value = .Value End With End Sub مني 4.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي حاولت تنفيدها بطريقة اخرى لتكون النتائج ادق وعدم تسبب المعادلات بثقل للملف زيادة على غياب تطابق عناوين الاعمدة على الجداول ودالك بتحويل المعادلات الى اكواد ووضع لكل يوم كود معين يتم تنفيده بشرط قيمة الخلية S3 ملاحظة 1) لقد قمت بحدف المغادلة الخاصة بجلب اسم اليوم من التاريخ في الخلية S3 ووضعت قائمة منسدلة تتضمن الايام من الاحد الى الخميس عند اختيارك اليوم المناسب يتم جلب بياناته تلقائيا 2) تم الاستغناء على معادلة الترقيم التلقائي للبيانات في عمود A واستبدالها بالاكواد 3) يتم تنفيد الكود المناسب عند التغيير في عمود الاسماء تلقائيا الكود الخاص بيوم الاحد للتوضيح Sub Sunday() Dim F1$, F2$, F3$, F4$, F5$, F6$, F7$, F8$, A$, B$, J% Dim MyRng As Range, MyDst As Range, Title As Range, R As Range, D As Range Dim MyDest As Worksheet: Set MyDest = Feuil1 Dim MyData As Worksheet: Set MyData = Feuil2 A = MyDest.Name B = MyData.Name Set C = MyData.Range("$D$4:$M$24") Set D = MyDest.Range("A22:A31") Set Title = MyDest.Range("B22:B31") Set MyRng = MyDest.Range("F22:U31") Application.ScreenUpdating = False MyDest.Unprotect "0000" D.ClearContents With MyDest F1 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",2,0),"""")" F2 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",4,0),"""")" F3 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",5,0),"""")" F4 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",6,0),"""")" F5 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",7,0),"""")" F6 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",8,0),"""")" F7 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",9,0),"""")" F8 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",10,0),"""")" [F22] = F1: [H22] = F2: [J22] = F3: [L22] = F4: [N22] = F5: [P22] = F6: [R22] = F7: [T22] = F8 .Range("F22:U22").AutoFill Destination:=.Range("F22:U31"), Type:=xlFillDefault MyRng.Value = MyRng.Value For Each R In Title If R.Value <> Empty Then J = J + 1 R.Offset(0, -1).Value = Format(J, "0") End If Next MyRng.Replace 0, "", xlWhole End With MyDest.Protect "0000" End Sub الكود الخاص بتنفيد الكود المناسب عند التغيير في خلية اليوم Sub Results() Select Case Range("S3") Case "الأحد": Sunday Case "الاثنين": Monday Case "الثلاثاء": Tuesday Case "الأربعاء": Wednesday Case "الخميس": Thursday End Select End Sub مع وضع الكود التالي في Worksheet.Change الورقة 1 Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Range("B22:B31")) Is Nothing Then Application.EnableEvents = False Call Results Application.EnableEvents = True Exit Sub End If If Not Intersect(Target, Range("S3")) Is Nothing Then Application.EnableEvents = False Call Results Application.EnableEvents = True End If On Error GoTo 0 End Sub التقرير اليومي مبرمج 2023.xlsm

لكن أخي الملف غير مطابق للصورة المرفقة اين مكان وجود الجدول الذي يتضمن أسماء الأيام

اخي انت واضع شرط انه لو قيمة الخلية قيمتها اصغر من 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