نجوم المشاركات

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

استاذ @alhourriah للاسف كل هذا بسبب استخدامك للغة العربية في اسماء الجداول النماذج الاستعلامات وغيرها..... وبارامتراتهما ..... فهذا بيلخبط البرمجة غصب عنك وعن أي مبرمج .!!!!!!!!!!

تفضل الكل يعمل baseF2.rar

Private Sub Form_BeforeUpdate(Cancel As Integer) If IsNull(Me.P_Odate) Then MsgBox "الرجاء إدخال تاريخ البدء", vbExclamation, "" Cancel = True ElseIf IsNull(Me.exbict) Then MsgBox "الرجاء إدخال تاريخ الانتهاء", vbExclamation, "" Cancel = True End If End Sub

يوجد جملة شرطية ليس لها نهاية بتوضيح أكثر ، عندك كود If ولم يتم إنهاء حدوده بالعبارة End If

تحتاج اعادة ترتيب للكود ...... وخاصة قاعدة IF

تم تحديث ملفات الروابط وإصلاح بعض الأخطاء ، والتعديل لبعض الملاحظات ...... ما زلنا قيد التطوير

في حدث Private Sub Worksheet_Activate ضع الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) Dim a, i&, k&, b$, S$, lRow& Dim WS As Worksheet: Set WS = Sheets("البيانات") Dim desWS As Worksheet: Set desWS = Sheets("البحث") b = desWS.[E2] On Error Resume Next Application.ScreenUpdating = False If Not Intersect(Target, Target.Worksheet.Range("E2")) Is Nothing Then If Target.Cells.Value = "" Or IsEmpty(Target) Then Exit Sub desWS.Range("A5:j" & Rows.Count).ClearContents a = WS.Range("A3:J" & WS.[a65000].End(xlUp).Row) For i = 1 To UBound(a) If a(i, 4) = b Or a(i, 7) = b Or a(i, 10) = b Then desWS.Cells(k + 5, 1).Resize(, 10) = Application.IfError(Application.Index(a, i, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)), "") k = k + 1 ActiveWindow.DisplayZeros = False End If Next lRow = desWS.Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set Rng = desWS.Range("A5 :J" & lRow) desWS.Range("A5:J500").Borders.LineStyle = xlNone For Each c In Rng.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next Application.ScreenUpdating = True End If End Sub السيارات 24.xlsb

عليكم السلام المجاميع المتغيرة ليس مكانها الجدول فقط يتم عرضها في النماذج والتقارير بواسطة الاستعلام .. او الكود كمصدر بيانات للحقل sumAm: nz(dsum("amount","tbl_BonusAmount","no_emp='" & no_emp & "'"),0) test12.rar

يعلم الله اني احب من هم على مثل همتك في طلب العلم ابدأ من الجداول .. هي الأساس وانا اعتبرها 80% من المشروع .. ودائما اذكر هذا في تعليقاتي اذا اتقنت عمل الجداول على الوجه الصحيح .. انتقل لما بعده نعم ستتبع كل شيء وتقوم بتعديله بما يتوافق مع المسميات في الجداول صحيح ستتعب ويأخذ من وقتك وجهدك .. ولكن ستحمد ذلك في النهاية وسيصبح عملك اكثر متعة واسرع في الفهم والتعلم

لا اعتقد اني فهمتك بشكل صحيح ولكن جرب التعديل التالي . Datab.accdb

تفضل أستاذ @banaz pc المرفق بعد التعديل حسب ما فهمت . ووافني بالرد. واذا كان هذا طلبك اضغط على أفضل إجابة . test1 (1).rar

عموما ساحاول لك كل الشكر والتقدير

HID_SH.rar

شكرا جزيلا لك اخى ابو مروان , لكن لا اعلم كيفية تطبيق ذلك على الملف

وعليكم السلام ورحمه وبركاته جرب المرفق لعله الملطلوب تم الاستعانه بالموضوع ادناه السيارات 24.xlsm ودا الكود المستخدم عدل عليه براحتك حسي الاحتياج Sub Trans_Data() '????? ??? ???????? ???? ?????? '????? ???? '?? ??? ????? ?? 15/11/2017 '????? ?? ????? ?? ??????? ???? ????? ???? '================ Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '??????? ?? ????? ???????' Dim Main As Worksheet, sh As Worksheet ' ??????? ?? ?????????? Dim Arr As Variant, Temp As Variant '(i,j)??????? ?? ????? ???????? ?????? ( p ) ????? ???????? ??????? Dim i As Long, j As Long, p As Long ' ??????? ?? ??????? ???? ??? ??? ????? ???? Dim dep As String Set Main = Sheets("1") Set sh = Sheets("2") '======= ' ??? ??????? ??????? sh.Range("A5:AC" & Main.Range("B" & Rows.Count).End(xlUp).Row).ClearContents ' ????? ???????? dep = sh.Range("e2").Value ' ???????? ?????? Arr = Main.Range("A3:AC" & Main.Range("B" & Rows.Count).End(xlUp).Row).Value ' ????? ???????? ????? ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) ' ??? ???????? ?????? For i = 1 To UBound(Arr, 1) '??? ???? ????? If Arr(i, 4) Like "*" & dep & "*" Then 'If Arr(i, 101) = dep Then ' ?????? ?????? ??? ???????? ????? p = p + 1 ' ??? ???????? ????? For j = 1 To UBound(Arr, 2) ' ????? ???????? ????? ?? ???????? ?????? ??? ????? Temp(p, j) = Arr(i, j) Next End If Next ' ???? ??????? ????? ????? '??? ???????? ???????? If p > 0 Then sh.Range("A5").Resize(p, UBound(Temp, 2)).Value = Temp sh.Range("A5:AC" & Rows.Count).Borders.Value = 0 '??? ?????? ??????? sh.Range("A5:AC" & Cells(Rows.Count, 2).End(xlUp).Row).Borders _ .Weight = xlMedium ' .Weight = xlThin ' .Weight = xlMedium ' .Weight = xlThick Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub

استاذ @سامر محمود من خلال قراءتي للمشاركة . المطلوب تحديث بيانات الجدول بدون ارالته حتى لا تتأثر العلاقات . فتم عمل ذلك من خلال المرفق وكمان تم برمجة باسوورد القاعدة الخلفية يعني البرنامج بيتعرف على القاعدة الخلفية دون كتابة الباسوورد . اليك المرفق .ووافني بالرد . DDTestSamer.rar

تفضل abouelhassan.xls

قد يكون ردي متأخراً ، واعتذر عن عدم المتابعة مني ومن صاحب الموضوع ، ولكن أعتقد افضل طريقة ولضمان عدم تلف العلاقات بين الجداول هو استيراد البيانات من الجدول المحدد وليس استيراد الجدول كاملا استناداً وتأييداً لكلامي أستاذنا @kanory . هذه نقطة ، والثانية هي مجرد فكرة خطرت ببالي من فكرة النسخ الإحتياطي للجداول واستعادة النسخة ، قد نستطيع فيما بعد بتوظيف الفكرة هذه لعمل استيراد للجداول حتى لو كانت مرتبطة بعلاقة 😅 هذه الجداول شكلها بنت عالم وناس 😂🤪

هذا هو ما أبحث عنه يا أستاذ @Moosak نقاط الضعف من وجهة نظر مستخدمين آخرين غيري جزاك الله كل الخير ، جاري العمل على تغييرات وإضافات إن شاء الله أن ترقى للمستوى المطلوب .