محمد هشام.

حاول اخي قبل الغاء تثبيت نسخة الاوفيس من الجهاز تجربت إعادة تعيين 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

1) قم بتحميل المرفق أولا والتأكد من حصولك على الإجابة المتوقعة بخصوص تعديل البيانات ... !!!! 2) قم بفتح موضوع جديد بطلبك وسوف نحاول كالعادة مساعدتك قدر المستطاع

ادا كنت تقصد تعديل بيانات اسم الصنف والكمية فقط تفضل جرب بعد استدعاء البيانات بشرط رقم الفاتورة برنامج المستودع 5 (1).xlsb

مزيدا من التألق والابداع بادن الله

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ربما هدا ما تقصد Option Explicit Sub Test() Dim i&, F&, K&, R&, lastrow& Dim Rng As Variant Dim Réf As Variant Dim DelRng As Range Dim sh As Worksheet: Set sh = Sheets("Sheet1") lastrow = sh.Columns("A:F").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Application.ScreenUpdating = False sh.Range("E7:F" & lastrow).ClearContents Rng = sh.Range("A7:B" & lastrow).Value ReDim Réf(1 To UBound(Rng, 1), 1 To UBound(Rng, 2)) F = 1 For i = LBound(Rng, 1) To UBound(Rng, 1) If Rng(i, 1) <> "" And Rng(i, 1) <> "الصافي" And Rng(i, 2) <> "" Then For K = LBound(Rng, 2) To UBound(Rng, 2) Réf(F, K) = Rng(i, K) Next K F = F + 1 End If Next i sh.Range("E7").Resize(F - 1, UBound(Réf, 2)).Value = Réf With sh For R = lastrow To 7 Step -1 'حدف العناوين 'If .Cells(R, "A").Value = "" Or .Cells(R, "B").Value = "" Or .Cells(R, "A").Value = "الصافي" Then If .Cells(R, "A").Value = Empty Or .Cells(R, "B").Value = Empty Then Set DelRng = .Range(.Cells(R, 1), .Cells(R, 2)) DelRng.Delete Shift:=xlUp End If Next R End With Application.ScreenUpdating = True End Sub 222222.xlsm

تم تصحيح كود التعديل فقط بعد تعديل اسماء التكست بوكس على ما اظن ان النسخة الاحدث منى 4 قد تم تعديل وتصحيح الاكواد بها .استغرب لما تقوم بحدف التعديلات دائما واعادة رفع نفس الملفات Dim SH As Worksheet: Set SH = ActiveSheet Dim X As Long Application.ScreenUpdating = False If Me.TextBox1.Value = Empty Then: Exit Sub X = Application.Match(Val(TextBox1.Value), SH.Columns("C"), 0) If Not IsError(X) Then For i = 1 To 35 SH.Cells(X, i + 2).Value = Controls("TextBox" & i).Value SH.Cells(X, i + 2).Value = SH.Cells(X, i + 2).Value Next i End If For R = 1 To 35 Me("Textbox" & R) = "" Next R Me.Recherche = "" SH.Range("C11").Value = 1 SH.Range("C11:C" & Range("E" & Rows.Count).End(xlUp).row).DataSeries , xlDataSeriesLinear مني 3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته المشكلة ليست في الحل اخي سعد طلبك ليس بالسهل يجب ان تعلم ان عكس اظهار البيانات على الليست بوكس يتطلب تعديل اكواد الترحيل والتعديل والحذف ...وهدا يلزمه بعض الوقت . Dim Col(), WSData, Largeur(), MyRng, ligne, F, ColSearch(), J Private Sub UserForm_Initialize() Dim A, B, C, D ' اسماء الجداول A = [Tableau1]: B = [Tableau2]: C = [Tableau3]: D = [Tableau4] ' التعامل مع ورقة العمل النشطة Set WSData = ActiveSheet ' نطاق البيانات Set MyRng = WSData.Range("C10:M" & WSData.[C65000].End(xlUp).Row) F = WSData.Range("C10:M" & WSData.[C65000].End(xlUp).Row).Value ' ترتيب الاعمدة الظاهرة على الليست بوكس Col = Array(11, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1) ' عرض الاعمدة Largeur = Array(60, 50, 60, 80, 65, 75, 75, 80, 170, 50, 15) Me.ListBox2.ColumnCount = UBound(Col) + 1 Me.ListBox2.ColumnWidths = Join(Largeur, ";") ' اظهار البيانات على الليست بوكس On Error Resume Next Me.ListBox2.List = Application.Index(MyRng, Evaluate("Row(1:" & MyRng.Rows.Count & ")"), Col) On Error GoTo 0 'اعمدة خاصة بفلترة الليست بوكس ColSearch = Array(11, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1) ' تم تحديد عمود اسم الطالب (يمكنك تعديله) J = UBound(ColSearch) + 1 'عناوين الليست بوكس Transférer Me.ListBox1.Visible = False Me.Show_file.Caption = "إظهار ملف العمل" ' رقم الصف ligne = WSData.[C65000].End(xlUp).Row + 1 Me.N_Row = ligne ' عدد الصفوف على الجداول NbLigne = [Tableau1].Rows.Count + [Tableau2].Rows.Count + [Tableau3].Rows.Count + [Tableau4].Rows.Count If Me.ComboBox1.Value = Empty Then Counter.Caption = "المجموع" & " / " & NbLigne Else Counter.Caption = Me.ComboBox1.Text & " / " & ListBox2.ListCount + 0 End Sub '******************************* Sub Transférer() On Error Resume Next i = 0 For Each C In Col i = i + 1 Me("MH" & i).Caption = MyRng.Offset(-1).Item(1, C) Next End '****************************** Sub Search() students_name = "*" & Me.TextBox12 & "*" Dim Tbl(): n = 0 For i = 1 To UBound(F) If F(i, 3) Like students_name Then ' فلترة باسم الطالب n = n + 1: ReDim Preserve Tbl(1 To J, 1 To n) C = 0 For Each k In ColSearch C = C + 1: Tbl(C, n) = F(i, k) Next k End If Next i If n > 0 Then Me.ListBox2.Column = Tbl Else Me.ListBox2.Clear End Sub محمد_3.xlsm