محمد هشام.

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

تفضل اخي اليك طلبك يمكنك تطويعه على حسب احتياجاتك Sub Créer_des_feuilles() Dim rng As Range, dico As Range, Cell As Range Dim arr(1 To 2) As String, f As Worksheet arr(1) = "المرجوا التحقق من إسم ورقة العمل" arr(2) = "تم نسخ اوراق العمل بنجاح" On Error GoTo Errorhandling NameWS = InputBox("أدخل إسم ورقة العمل المراد نسخها ", " نسخ ورقة العمل") If Evaluate("ISREF('" & NameWS & "'!A1)") Then Set rng = Application.InputBox(Prompt:=" حدد نطاق أسماء أوراق العمل: ", _ Title:="تسمية أوراق العمل", _ Default:=Selection.Address, Type:=8) For Each dico In rng If dico <> Empty Then Application.ScreenUpdating = False If Not Evaluate("ISREF('" & dico & "'!A1)") Then Sheets(NameWS).Copy After:=ActiveWorkbook.Sheets(Worksheets.Count) Set f = ActiveSheet: f.Name = dico: f.DrawingObjects.Delete: f.UsedRange = f.UsedRange.Value For Each Cell In dico ws = ws & vbCrLf & Cell.Value Next Cell End If End If Next dico Application.ScreenUpdating = True MsgBox arr(2) & vbCrLf & ws, vbOKOnly, "تعليمات:" Else MsgBox arr(1), vbCritical, "إنتباه:" End If Errorhandling: End Sub Create-Sheets.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاستاد محمد صالح اليك حلول اخرى =INDEX($B$2:$D$6, MATCH(A10,$A$2:$A$6,0), MATCH(B10, $B$1:$D$1, 0)) او =HLOOKUP(I12,$H$1:$K$6,MATCH(H12,$H$1:$H$6,0),0) اوفيسنا.xlsx

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

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

Sub test1() Dim WS As Worksheet: Set WS = ActiveSheet '<<<---- Worksheets("27-10-2023الى2-11-2023") 'اسم ورقة العمل Dim lastrow As Long, ligne As Range, search As Rang Set ligne = [U4] '<<<----' خلية اللصق Set search = [L19] '<<<-- اي القيمة التي تم جلبها من الخلية '<<<---اول تاريخ على الجدول ("A4") ' '("U")' تحديد اخر خلية بها بيانات من عمود lastrow = WS.Cells(Rows.Count, 23).End(xlUp).Row + 1 ' لمنع التكرار '*********************** '("U") 'التحقق من وجود نفس تاريخ المدفوعات مسبقا في عمود ' ' في حالة وجوده يتم ايقاف تنفيد الكود مع رسالة اشعار If Application.WorksheetFunction.CountIf(WS.Range("U:U"), search) > 0 Then MsgBox " يوجد نفس الفترة في المدفوعات " & search, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub A = [L19:Q51].Value ''<<<----'نطاق البيانات المرحلة If ligne = 0 Then ' '<<<----التحقق من عدم وجود قيمة في خلية اللصق ' U4'في حالة فراغها يتم لصق البيانات ابتداءا من الخلية [U4].Resize(UBound(A), UBound(A, 2)).Value2 = A Else ' U ' في حالةوجودقيمة يتم لصق البيانات بعد اخر صف به بيانات من عمود Range("U" & lastrow).Resize(UBound(A), UBound(A, 2)).Value2 = A End If MsgBox "تم ترحيل مدفوعات" & " " & search & " " & "بنجاح", vbInformation End Sub

حاول اخي قبل الغاء تثبيت نسخة الاوفيس من الجهاز تجربت إعادة تعيين Microsoft Excel إلى الإعدادات الافتراضية ربما تفيدك

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

ربما اخي سبب تاخير الرد هو طريقة طرحك لطلبك السؤال هو هل تقصد انك تريد جلب البيانات بشرط رقم الصنف واسم الصنف ابتداءا من تاريخ البداية وهو الخلية b11 الى غاية تاريخ اليوم وهو الخلية b5 من الشيت رقم 6 ووضعها في الاعمدة C,D,E ومن الشيت رقم 8 ووضعها في الاعمدة F,G,H مع جلب اسم الصنف للخلية D8 من شيت 4 بشرط الخلية C8

ادن اخي تفاصيل أخرى يجب ألا تفوتها اثناء تصميمك للملف عند إظهار نموذج مستخدم وإخفائه ، يبقى النمودج في الذاكرة ، إذا قمت بالعملية عدة مرات دون تنزيله ، فقد يكون لديك خطأ في تشبع الذاكرة ، و توقف البرنامج عن العمل ولهذا السبب من المهم استخدام الماكرو التالي: Sub Unload_Forms() Dim i As Long, Model As Object On Error Resume Next ' لنفترض انك لديك 100 يوزر على المصنف For i = 1 To 100 Set Model = CallByName(UserForms, "Add", VbMethod, "UserForm" & i) Unload Model Next On Error GoTo 0 End Sub اليك اخي الملف عليه 16 يوزرفورم للتجربة واختيار ما يناسبك بعد اظافة الاحتمالات الواردة اسفله : اولا في حالة كنت ترغب بتوحيد وقت الظهور والاخفاء على جميع النمادج يمكنك استخدام الكود التالي Sub Model_Show() Dim i As Long Dim Model As Object Login_screen.Show ' نمودج المقدمة Application.Wait Now + TimeValue("00:00:5") Unload Login_screen For i = 1 To 16 '<<<---- ' عدد النمادج المرغوب اظهارها' Set Model = CallByName(UserForms, "Add", VbMethod, "UserForm" & i) Application.Visible = False With Model Model.Show Model.Repaint Application.Wait Now + TimeValue("00:00:2") ' تحديد المدة Model.Hide End With Next ' افراغ الداكرة On Error Resume Next For i = 1 To 16 Set Model = CallByName(UserForms, "Add", VbMethod, "UserForm" & i) Unload Model Next Application.Visible = True End Sub الاحتمال رقم 2 وهو الارجح ربما لطلبك Option Explicit Sub View_User1() Application.Visible = False On Error Resume Next Login_screen.Show Application.Wait Now + TimeValue("00:00:12") Unload Login_screen '****************************** UserForm1.Show UserForm1.Repaint Application.Wait Now + TimeValue("00:00:5") Unload UserForm1 '****************************** '********* اتمم الكود بنفس الطريقة********* '****************************** UserForm16.Show UserForm16.Repaint Application.Wait Now + TimeValue("00:00:3") Unload UserForm16 Application.Visible = True End On Error GoTo 0 End Sub الاحتمال رقم 3 هو انك لا تريد تعديل الكود السابق ادن ما عليك هو جعل الكود بالطريقة التالية Option Explicit Sub View_User2() Application.Visible = False On Error Resume Next Login_screen.Show Application.Wait Now + TimeValue("00:00:5") Unload Login_screen '****************************** UserForm1.Show UserForm1.Repaint Application.Wait Now + TimeValue("00:00:3") UserForm1.Hide '*********اتمم الكود بنفس الطريقة********* ' افراغ الداكرة Call Unload_Forms Application.Visible = True End On Error GoTo 0 End Sub للانتقال بين النمادج قبل نهاية المدة يمكنك الظغط على زر {ESC} / Échap على ما اظن انه الان بين يديك جميع الاحتمالات الواردة لتتمكن من اتمام ملفك وغلق الموضوع بادن الله تجربة 3.rar

تفضل اخي ربما هدا ما تقصده نفس الفكرة لاكن بطرق مختلفة يمكنك اختيار ما يناسيك Sub test1() Dim WS As Worksheet: Set WS = ActiveSheet Dim lastrow As Long, ligne As Range, search As Range Set ligne = [U4]: Set search = [L19] lastrow = WS.Cells(Rows.Count, 23).End(xlUp).Row + 1 If Application.WorksheetFunction.CountIf(WS.Range("U:U"), search) > 0 Then MsgBox " يوجد نفس الفترة في المدفوعات " & search, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub A = [L19:Q51].Value If ligne = 0 Then [U4].Resize(UBound(A), UBound(A, 2)).Value2 = A Else Range("U" & lastrow).Resize(UBound(A), UBound(A, 2)).Value2 = A End If MsgBox "تم ترحيل مدفوعات" & " " & search & " " & "بنجاح", vbInformation End Sub '***********************او**************************** Sub test2() Dim WS As Worksheet: Set WS = ActiveSheet Dim F As Variant, Data As Range Dim lastrow As Long, ligne As Range, search As Range Set ligne = [U4]: Set search = [L19] Set Data = WS.Range("L19:Q51") If Application.WorksheetFunction.CountIf(WS.Range("U:U"), search) > 0 Then MsgBox " يوجد نفس الفترة في المدفوعات " & search, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub F = Application.Index(Data, Evaluate("Row(1:" & Data.Rows.Count & " )"), Array(1, 2, 3, 4, 5, 6)) lastrow = WS.Cells(Rows.Count, 23).End(xlUp).Row + 1 If ligne = 0 Then WS.[U4].Resize(UBound(F, 1), UBound(F, 2)) = F Else WS.Range("U" & lastrow).Resize(UBound(F, 1), UBound(F, 2)) = F End If MsgBox "تم ترحيل مدفوعات" & " " & search & " " & "بنجاح", vbInformation End Sub '***********************او**************************** Sub test3() Dim WS As Worksheet: Set WS = ActiveSheet Dim lastrow As Long, ligne As Range, search As Range Set ligne = [U4]: Set search = [L19] Set Data = WS.Range("L19:L51,M19:M51,N19:N51,O19:O51,P19:P51,Q19:Q51") Tbl = Réf(Data) lastrow = WS.Cells(Rows.Count, 23).End(xlUp).Row + 1 If Application.WorksheetFunction.CountIf(WS.Range("U:U"), search) > 0 Then MsgBox " يوجد نفس الفترة في المدفوعات " & search, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub If ligne = 0 Then [U4].Resize(UBound(Tbl), UBound(Tbl, 2)) = Tbl Else WS.Range("U" & lastrow).Resize(UBound(Tbl), UBound(Tbl, 2)) = Tbl End If MsgBox "تم ترحيل مدفوعات" & " " & search & " " & "بنجاح", vbInformation End Sub Function Réf(Data) K = Data.Rows.Count: Col = Data.Areas.Count Dim Tbl(): ReDim Tbl(1 To K, 1 To Col) For i = 1 To Col For J = 1 To K: Tbl(J, i) = Data.Areas(i)(J): Next J Next i Réf = Tbl End Function Book2.xls

ربما Option Explicit Sub Sup_tous_les_filtres() Dim WS As Worksheet For Each WS In Worksheets Application.ScreenUpdating = False WS.Activate On Error Resume Next WS.Range("A8").Select ActiveSheet.ShowAllData Selection.End(xlDown).Select On Error GoTo 0 Next End Sub

أستاذ @ياسر خليل أبو البراء ليس هناك أي فرق لهذا لم أرغب بوضع الكود مرة أخرى والاكتفاء بارفاق الملف ليقوم الأخ @sabah2023 للتجربة لاغير.

تنسيق - 2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته في حالة الرغبة في استخدام الاكواد يمكنك تجربة المرفق التالي date3.xlsb

اليك حل اخر بعد اظافة معادلة الاخ محمد صالح Sub Test2() Set d = CreateObject("Scripting.Dictionary") k = Range("b2:D" & [b65000].End(xlUp).Row) Dim Rng(): ReDim Rng(1 To UBound(k), 1 To UBound(k, 2)) For i = LBound(k) To UBound(k) Réf = k(i, 1) & "|" & k(i, 2) & "|" & k(i, 3) If d.exists(Réf) Then lig = d(Réf) Else d(Réf) = d.Count + 5: lig = d.Count: Rng(lig, 1) = k(i, 1): Rng(lig, 2) = k(i, 2): Rng(lig, 3) = k(i, 3) End If Next i [j2].Resize(d.Count, UBound(Rng, 2)) = Rng End Sub نقل الاسماء بدون تكرار بشروط.xlsb

ربما لم تراجع الموضوع السابق من قبل

كما ذكر الأخ @محي الدين ابو البشر من قبل مازال طلبك الأخير غير واضح نهائيا .!!!!

وعليكم السلام ورحمة الله تعالى وبركاته أولا أخي أنصحك بالاشتغال على آخر ملف تم تعديله لأنني لاحظت أنك لم تقم بنسخ الأكواد بالطريقة الصحيحة .هناك عدة أخطاء لهذا ستلاحظ عدم اشتغال اكواد الحدف والتعديل وكذلك الاظافة في ورقة 7 2) اما بالنسبة لطلبك الأخير ربما لو حاولت توصيل الفكرة بشكل أفضل سوف يحاول جميع الإخوة مساعدتك .

تفضل جرب Sub test() Dim i As Integer i = 2 For Each sh In ThisWorkbook.Worksheets Select Case sh.Name Case Is = "Sheet1", "Sheet2", "Sheet3", "Sheet7" '<----- 'تجاهل الاوراق التالية Case Else Application.ScreenUpdating = False ActiveWorkbook.Sheets("Sheet1").Hyperlinks.Add _ Anchor:=ActiveWorkbook.Sheets("Sheet1").Cells(i, 1), _ Address:="", _ SubAddress:="'" & sh.Name & "'!A1", _ TextToDisplay:=sh.Name sh.Hyperlinks.Add Anchor:=sh.Range("E1"), Address:="", SubAddress:="Sheet1" & "!A1", TextToDisplay:="رجوع" sh.Range("E1").Font.Size = 30: sh.Rows(1).AutoFit i = i + 1 End Select Next sh Application.ScreenUpdating = True End Sub ارتباط تشعبي.xlsm

Sub test4() Dim sh As Worksheet: Set sh = Sheets("Sheet1") Lr = sh.Columns("I:N").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set a = Range("F2:F" & [F65000].End(xlUp).Row) Set b = Range("I2:N" & Lr) Application.ScreenUpdating = False Set R1 = CreateObject("Scripting.Dictionary") Set R2 = CreateObject("Scripting.Dictionary") For Each J In a R1(J.Value) = J.Value Next J For Each J In b R2(J.Value) = J.Value If Not R1.exists(J.Value) And R2(J.Value) <> "" Then J.Interior.ColorIndex = 36 If R1.exists(J.Value) Or R2(J.Value) = "" Then J.Interior.ColorIndex = xlNone Next J End Sub مقارنة بيانات عمود ببيانات عمود اخر 2.xls او Private Sub Worksheet_Change(ByVal Target As Range) Lr = Columns("I:N").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set a = Range("F2:F" & [F65000].End(xlUp).Row) Set b = Range("I2:N" & Lr) With Target Select Case .Column Case 6, 9, 10, 11, 12, 13, 14 If .Row > 1 Then Application.ScreenUpdating = False Application.EnableEvents = False Set R1 = CreateObject("Scripting.Dictionary") Set R2 = CreateObject("Scripting.Dictionary") For Each j In a: R1(j.Value) = j.Value: Next j For Each j In b: R2(j.Value) = j.Value If Not R1.exists(j.Value) And R2(j.Value) <> "" Then j.Interior.ColorIndex = 42 If R1.exists(j.Value) Or R2(j.Value) = "" Then j.Interior.ColorIndex = xlNone Next j Application.EnableEvents = True Application.ScreenUpdating = True End If End Select End With End Sub

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

Private Sub CommandButton1_Click() Dim lr As Long Dim ws As Worksheet: Set ws = Sheet8 Application.ScreenUpdating = False lr = ws.Cells(Rows.Count, 5).End(xlUp).Row lr = lr + 1 ws.Cells(lr, 5) = Me.TextBox1.Value ws.Cells(lr, 6) = Me.TextBox2.Value ws.Cells(lr, 7) = Me.TextBox3.Value ws.Cells(lr, 8) = Me.TextBox4.Value ws.Cells(lr, 9) = Me.TextBox5.Value ws.Cells(lr, 10) = Me.TextBox6.Value ws.Cells(lr, 11) = Me.TextBox7.Value ws.Cells(lr, 12) = Me.TextBox8.Value ws.Cells(lr, 13) = Me.TextBox9.Value ws.Cells(lr, 14) = Me.TextBox10.Value ws.Cells(lr, 15) = Me.TextBox11.Value ws.Cells(lr, 16) = Me.TextBox12.Value ws.Cells(lr, 17) = Me.TextBox13.Value For i = 1 To 13 Controls("textbox" & i).Text = "" Next i Application.ScreenUpdating = True End Sub او Private Sub CommandButton1_Click() Dim lr As Long Dim ws As Worksheet: Set ws = Sheet8 Application.ScreenUpdating = False lr = ws.Range("E" & Rows.Count).End(xlUp).Row With ws .Cells(lr + 1, "E").Value = Me.TextBox1.Value .Cells(lr + 1, "F").Value = Me.TextBox2.Value .Cells(lr + 1, "G").Value = Me.TextBox3.Value .Cells(lr + 1, "H").Value = Me.TextBox4.Value .Cells(lr + 1, "I").Value = Me.TextBox5.Value .Cells(lr + 1, "J").Value = Me.TextBox6.Value .Cells(lr + 1, "K").Value = Me.TextBox7.Value .Cells(lr + 1, "L").Value = Me.TextBox8.Value .Cells(lr + 1, "M").Value = Me.TextBox9.Value .Cells(lr + 1, "N").Value = Me.TextBox10.Value .Cells(lr + 1, "O").Value = Me.TextBox11.Value .Cells(lr + 1, "P").Value = Me.TextBox12.Value .Cells(lr + 1, "Q").Value = Me.TextBox13.Value End With For i = 1 To 13 Controls("textbox" & i).Text = "" Next i Application.ScreenUpdating = True End Sub

رزة1 (2).xlsm

Private Sub Worksheet_Change(ByVal Target As Range) Set a = Range("F2:F" & [F65000].End(xlUp).Row) Set b = Range("I2:I" & [I65000].End(xlUp).Row + 10) Set rng1 = CreateObject("Scripting.Dictionary") Set rng2 = CreateObject("Scripting.Dictionary") If Target.Column <> 6 And Target.Column <> 9 Then Exit Sub For Each J In a rng1(J.Value) = J.Value Next J For Each J In b rng2(J.Value) = J.Value If Not rng1.exists(J.Value) And rng2(J.Value) <> "" Then J.Interior.ColorIndex = 36 If rng1.exists(J.Value) Or rng2(J.Value) = "" Then J.Interior.ColorIndex = xlNone Next J End Sub test.xlsb