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

اقرب واسهل طريقة هو ان يتم حفظ قيمة الحقل عند التركيز وقبل اجراء اي تغيير Dim i As String Private Sub item_GotFocus() i = Me.item End Sub Private Sub item_BeforeUpdate(Cancel As Integer) Me.note = i End Sub New2.accdb

هذا الموضوع ذكرني بموضوع شاركت فيه وصاحبه يعاني وسيستمر يعاني إن لم يسمع الكلام ويستفيد من نصائح الخبراء: إذا كان الموضوع له علاقة بالوقت فالأمر يختلف ولكن إذا كان الأمر له علاقة بالتواريخ فلننتبه إلى التالي والفرق بينها: في المدد هناك: - نهاية المدة (آخر يوم في المدة) End Date أو Last Date أو To Date - تاريخ الإنتهاء أو تاريخ الإستئناف أو تاريخ مباشرة العمل بعد انقطاع (أول يوم بعد انتهاء مدة إجازة مثلا) Expiry Date أو Resume Date فشهر يناير يبدأ من 01/01 وينتهي في 31/01 وليس 01/02 ومدته ستكون 31 يوم والأسبوع يبدأ بالأحد وينتهي بالسبت وليس الأحد ومدته ستكون 7 أيام فلنحسن المسمى لنحسن الحساب، لا أريد أن أتكلم عن خبراتي حتى لا تتعرفوا على شخصيتي الأصل 🙂 لو سأحسب الغياب لموظف غاب يوم 5 يناير سأسجله في جدول يحتوي على حقلين مثلا سيكون غيابه من 05/01 إلى 05/01. تحبون تعقدونها على الرجال عقدوها كما تعقد صاحبنا في الموضوع المشار إليه أعلاه 🙂 . ولا أستبعد من تواصل معه عبر الرسائل وقدم له نصيحة خاطئة.

هذه الأكواد و ليس برنامج متكامل ينقص البرنامج بعض اللمسات ويكون جاهزا الأكواد والأعمال لأصحابها وليس لي الفضل الا في تجميعها وتنسيقها فجزى الله كل من كانت له بصمه في هذا العمل كنترول محمدي9.xlsb كلمة سر فتح البرنامج 111

هشوف واخبرك باذن الله تعالي بارك الله فيك اخي

السؤال ده عاوز خبير بس حضرتك هوه علشان فيه أعمده محسوبة على الجدول ده شوف كل حاجة تمام و لا لأ يعنى شوف فيه حاجة اتمسحت من الحقول المحسوبة

تم الامر بنجاح اخي الكريم ولكن اعطاني رسائل تحذيرية فهل ممكن ننغير العلاقات بسبب تغير خصائص الحقل اخي

اعمل حجم الحقل مزدوج من الجدول ITEM_PRICE بالتوفيق

وهذا اسم النموذج PURCHASING_HEADER

حمد لله على السلام استاذنا حفظكم الله ورعاكم وجزاكم الله خيراً

تفضل اخي تم الاعتماد على رقم التسلسل لتعديل البيانات او حدفها بحكم انه هو الوحيد الغير مكرر عندك على الجدول Sub Délete_Client() ' حدف Dim WS As Worksheet, WS2 As Worksheet Dim i As Long, ST As Long Dim msg As VbMsgBoxResult, Client As String Set WS = Worksheets("Orders") Set WS2 = Worksheets("Items") Client = WS2.Range("F4") N_row = WS2.Range("W1") Application.ScreenUpdating = False If Client = Empty Then MsgBox Client & "المرجوا تحديد الصف المراد حدف بياناته", vbExclamation, "إنتباه" Exit Sub End If msg = MsgBox(" هل انت متأكد من حدف : " & Client, vbYesNo + vbQuestion + vbDefaultButton2, "إنتباه") Application.ScreenUpdating = False If msg = vbNo Then Exit Sub End If WS.Activate For i = Cells(Rows.Count, 2).End(xlUp).Row To 7 Step -1 If Cells(i, 2).Value = N_row Then Rows(i).Delete End If Next i For ST = 7 To Cells(Rows.Count, "B").End(xlUp).Row If Cells(ST, "c").Value <> "" Then Cells(ST, "b").Value = ST - 6 End If Next ST WS2.Activate WS2.Range("H15,F4,F6,H6,F9,H9,J9,F13,H13,J13,F15,J15,F18,H18,F20,J21,w1") = Empty Application.ScreenUpdating = True m = MsgBox("تم حدف البيانات بنجاح", 64, "تأكيد") End Sub Dynamic Orders - Pivot_V6.xlsm

أشكر الجميع على المرور بالنسبة للوقت هناك بند غرامات تأخير حيث متعارف عليه الاستلام مثلا الساعة 9 صباحا والتسليم الساعة 6 مساءا واي تأخير يدفع غرامات اتوقع +1 تحل المشكلة ربي يحفظكم ويبقى هذا الصرح العلمي الرائع منارة يهتدي بها التائهون وحفظكم الله اصدقائي الاكارم على المرور ابداء الرأي

Very bad approach to use macro recorder Generally try the code that do the same steps Sub Test() Dim rng As Range, lr As Long With ActiveSheet If .Range("A10").Value = Empty Then MsgBox "Enter Number", vbExclamation: Exit Sub Application.ScreenUpdating = False Set rng = .Range("A10").Resize(, 9) lr = .Cells(Rows.Count, "Z").End(xlUp).Row + 1 .Range("Z" & lr).Resize(, 9).Value = rng.Value rng.SpecialCells(xlCellTypeConstants).ClearContents Application.ScreenUpdating = True End With End Sub

الدالة int تقرب الى اصغر قيمة للعدد الصحيح 9.5 = 9 اما الاعداد السالبة فتقرب الى العدد الاكبر 9.5- = 10- لذا ان كانت الحقول تحتمل وجود كسور عشرية فان استخدامها لن يعود بنتيجة صحيحة والافضل استخدام val val([text1])+val([text2])

اظهاز طلاب الدور التاني 'هذا الكود للمحترم النابغه ياسر خليل ' الهدف من الكود هو استدعاء بشرط من خارج الكود 'تم هذا الكود في 15/2/2017 '==*==*==*==*==*==*==*==*==*==* Sub كشوف_كنترول_ثان() ActiveSheet.Unprotect Dim Arr As Variant Dim Arry As Variant Dim Lr As Long Dim i As Long Dim J As Long Dim Main As Worksheet Dim sh As Worksheet Dim NUM1 As Integer Dim NUM2 As Integer Dim Trgt1 As String Dim Trgt2 As String 'رقم عمود البحث NUM1 = 133 'عمود الشرط الاول NUM2 = 144 'عمود الشرط الثاني '=*=*=*=*=*=*=*=*=*=*=*=* Set Main = Sheets("رصد الترم الثانى") Set sh = Sheets("كشوف الترم الأول") 'خليه البحث Trgt1 = sh.Range("D1") & "*" 'الشرط الاول Trgt2 = sh.Range("E1").Value 'الشرط الثاني On Error Resume Next 'مدى المسح في صفحه الهدف '=========================================================== sh.Range("A7:AM1000").ClearContents '=========================================================== Lr = Main.Cells(Rows.Count, 1).End(xlUp).Row '=========================================================== Arr = Main.Range("A7:GB" & Lr).Value '=========================================================== 'مدى صفحه الهدف Arry = sh.Range("A7:AM1000") J = 1 For i = LBound(Arr, 1) To UBound(Arr, 1) 'رقم عمود البحث 'If arr(i, NUM1) Like Trgt1 Then 'If arr(i, NUM1) Like Trgt1 & "*" Then If Arr(i, NUM1) Like Trgt1 & "*" And Arr(i, NUM2) Like Trgt2 Then '=========================================================== Arry(J, 1) = J 'العمود الاول بعد المسلسل Arry(J, 2) = Arr(i, 2) Arry(J, 3) = Arr(i, 3) Arry(J, 4) = Arr(i, 140) Arry(J, 5) = Arr(i, 142) Arry(J, 6) = Arr(i, 143) Arry(J, 7) = Arr(i, 14) Arry(J, 8) = Arr(i, 15) Arry(J, 9) = Arr(i, 25) Arry(J, 10) = Arr(i, 26) Arry(J, 11) = Arr(i, 36) Arry(J, 12) = Arr(i, 37) Arry(J, 13) = Arr(i, 47) Arry(J, 14) = Arr(i, 48) Arry(J, 15) = Arr(i, 60) Arry(J, 16) = Arr(i, 61) Arry(J, 17) = Arr(i, 68) Arry(J, 18) = Arr(i, 69) Arry(J, 19) = Arr(i, 75) Arry(J, 20) = Arr(i, 76) Arry(J, 21) = Arr(i, 82) Arry(J, 22) = Arr(i, 83) Arry(J, 23) = Arr(i, 89) Arry(J, 24) = Arr(i, 90) Arry(J, 25) = Arr(i, 96) Arry(J, 26) = Arr(i, 97) Arry(J, 27) = Arr(i, 98) Arry(J, 28) = Arr(i, 99) Arry(J, 29) = Arr(i, 99) Arry(J, 30) = Arr(i, 109) Arry(J, 31) = Arr(i, 110) Arry(J, 32) = Arr(i, 131) Arry(J, 33) = Arr(i, 132) Arry(J, 34) = Arr(i, 133) Arry(J, 35) = Arr(i, 134) '=========================================================== J = J + 1 End If Next i With sh '=========================================================== 'خليه بدايه اللصق .Range("B7").Resize(J - 1, UBound(Arry, 2)).Value = Arry 'مدى المسح في صفحة الهدف .Range("A7:AM" & Rows.Count).Borders.Value = 0 '=========================================================== 'سطر لاضافة التسطير .Range("B7:AM" & .Cells(Rows.Count, 4).End(xlUp).Row).Borders.Value = 1 End With Erase Arr Erase Arry ActiveSheet.Protect End Sub

كود التنقل بين الصفحات Sub SheetList_CP() Application.CommandBars("Workbook Tabs").ShowPopup Range("A1").Select End Sub طباعه ارقام معينه بالنسبه للتيكيت Private Sub CommandButton1_Click() Dim X As Long, Y As Long, Z As Byte ' وضع قيمة التكست بوكس 2 داخل المتغير Y Y = TextBox2.Value ' وضع قيمة التكست بوكس 3 داخل المتغير Z Z = TextBox3.Value 'حلقة تكرارية بداية من التكست بوكس 1 الى المتغير واي الذي يحمل قيمة التكست2 For X = TextBox1.Value To Y 'هنا يتم وضع ارقام الجلوس تباعا لكل خلية من التسع خلايا 'اول خلية تساوى المتغير اكس والذي يحمل ارقام الجلوس التى حددناها من قبل 'والخلية التالية نضع املتغير اكس بالاضافة الى واحد ليحمل رقم الجلوس التالي 'وهكذا مع الخلايا الاخرى الخاصة بارقام الجلوس 'اما الشروط المضافة بجانب الخلايا IF[]>y then []="" 'فهذه تم وضعها فقط للتأكد من ان قيمة الخلايا لا تزيد عن اخر رقم جلوس وهو ما يحمله المتغير واي 'فاذا تحقق الشرط وكان رقم الجلوس اكبر من اخر رقم يتم مسحه وهذه الشروط لا نستعملها الا في اخر صفحة يتم طباعتها [B8] = X: If [B8] > TextBox2.Value Then [B8] = "" [B14] = X + 3: If [B14] > Y Then [B14] = "" [B20] = X + 6: If [B20] > Y Then [B20] = "" [B26] = X + 9: If [B26] > Y Then [B26] = "" [B32] = X + 12: If [B32] > Y Then [B32] = "" [B38] = X + 15: If [B38] > Y Then [B38] = "" '============ [H8] = X + 1: If [H8] > Y Then [H8] = "" [H14] = X + 4: If [H14] > Y Then [H14] = "" [H20] = X + 7: If [H20] > Y Then [H20] = "" [H26] = X + 10: If [H26] > Y Then [H26] = "" [H32] = X + 13: If [H32] > Y Then [H32] = "" [H38] = X + 17: If [H38] > Y Then [H38] = "" '============ [N8] = X + 2: If [N8] > Y Then [N8] = "" [N14] = X + 5: If [N14] > Y Then [N14] = "" [N20] = X + 8: If [N20] > Y Then [N20] = "" [N26] = X + 11: If [N26] > Y Then [N26] = "" [N32] = X + 14: If [N32] > Y Then [N32] = "" [N38] = X + 17: If [N38] > Y Then [N38] = "" '=========== 'سطر الطباعة وعدد النسخ تساوي z 'والتى تساوي تكست بوكس تلاته التى نضع بها عدد النسخ المطلوبة ActiveWindow.SelectedSheets.PrintOut Copies:=Z ', Preview:=True 'هنا نقوم باضافة ثمانية ارقام الى المتغير اكس ليصبح محموعهم 9 ليتخطى تسع ارقام جلوس كل دورة 'داخل الحلقة التكرارية حتى نهاية الحلقة X = X + 18 'نكست اي يعود مرة اخرى لاول الحلقة التكرارية لتطبيق الاكواد مرة اخرى Next ' MsgBox "Done.....", 64 Me.Hide End Sub Private Sub UserForm_Activate() 'هنا في حدث تنشيط الفورم 'تكست واحد تساوى اول رقم جلوس TextBox1.Text = Sheets("بيانات الطلبة").Range("B7").Value 'تكست2 تساوي اخر رقم جلوس TextBox2.Text = Sheets("بيانات الطلبة").Range("B" & Sheets("بيانات الطلبة").Cells(Rows.Count, 2).End(xlUp).Row).Value End Sub

وممكن نختصر الامر في حدث بعد التحديث نضع الامر Dim i As String i = Nz(item.OldValue, "") note = i

استدعاء كشوف اللجان Sub Legan_Test() ActiveSheet.Unprotect Password:="1" Dim Main As Worksheet Dim sh As Worksheet Dim Arr As Variant Dim arrC As Variant Dim temp1 As Variant Dim temp2 As Variant Dim Lr As Long Dim i As Long Dim J As Long Dim k As Long Dim p1 As Long Dim p2 As Long '======================= 'اسم صفحة المصدر Set Main = Sheets("بيانات الطلبة") 'اسم صفحة الهدف Set sh = Sheets("كشوف المناداة ") Lr = Main.Cells(Rows.Count, 5).End(xlUp).Row Application.Calculation = xlCalculationManual Application.EnableEvents = False Application.ScreenUpdating = False 'مدى المسح في كشفي اللجان sh.Range("C10:F46").ClearContents sh.Range("K10:N46").ClearContents sh.Rows("10:46").Hidden = False 'مدى صفحة المصدر Arr = Main.Range("A7:V" & Lr).Value 'الاعمده المطلوب نقلها من صفحه المصدر arrC = Array(2, 5, 15, 16) ReDim temp1(1 To UBound(Arr, 1) + 1, 0 To UBound(arrC) + 1) ReDim temp2(1 To UBound(Arr, 1) + 1, 0 To UBound(arrC) + 1) For i = 1 To UBound(Arr) 'رقم عمود رقم اللجان في صفحه المصدر If Arr(i, 18) = sh.Range("E3").Value Then p1 = p1 + 1 For J = 0 To UBound(arrC) temp1(p1, J) = Arr(i, arrC(J)) Next J End If If Arr(i, 18) = sh.Range("M3").Value Then p2 = p2 + 1 For J = 0 To UBound(arrC) temp2(p2, J) = Arr(i, arrC(J)) Next J End If Next i If p1 > 0 Then sh.Range("C10").Resize(p1, UBound(temp1, 2)).Value = temp1 If p2 > 0 Then sh.Range("K10").Resize(p2, UBound(temp2, 2)).Value = temp2 If p1 > 0 Then k = p1 If p2 > 0 And p2 > k Then k = p2 k = k + 10 'لاخفاء الصفوف الفارغه في كشف اللجان If k < 46 Then sh.Rows(k & ":46").Hidden = True Erase temp1 Erase temp2 ActiveSheet.Protect Application.Visible = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Application.ScreenUpdating = True End Sub ' Application.Calculation = xlManual ' Application.EnableEvents = False 'Application.ScreenUpdating = False طباعه كشوف اللجان Sub طباعة_منادااه() MsgBox "للحصول على طباعة كاملة يجب عدم ملامسة الماوس أو لوحة المفاتيح أثناء الطباعة" Dim i As Integer For i = Range("B1") To Range("B2") Step 2 If i <= Range("B2") Then Range("F1") = i ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1, Collate:=True End If Next i Range("B10").Select End Sub طباعه لجنه واحده من كشوف المناداه '***************************** Sub طباعه_لجنه() Dim LatR As Long LatR = Range("D:D").Find("*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1 With ActiveSheet .PageSetup.PrintArea = "A4:O" & LatR .PrintOut End With End Sub

هذا كود لحمايه ملف اكسيل Sub Protec() ' قبل وضع الكود ... 'لابد من جعل الخلايا كلها 'unlocked 'حدد خلايا ورقة العمل بالكامل 'ثم كليك يمين ثم اختار آخر تبويب 'ثم أزيل علامة الصح بجانب الخيار 'Lock وكذلك Hidden '================= Application.ScreenUpdating = False Dim mySheet As Worksheet Dim myPassword As String With Application .DisplayFullScreen = False .CommandBars("Worksheet Menu Bar").Enabled = True .CommandBars("Standard").Visible = True .CommandBars("Formatting").Visible = True .DisplayFormulaBar = True .DisplayStatusBar = False End With myPassword = "" On Error Resume Next For Each mySheet In ActiveWorkbook.Sheets With mySheet .Unprotect myPassword .Cells.Locked = False .Cells.SpecialCells(xlCellTypeFormulas).Locked = True .Cells.SpecialCells(xlCellTypeFormulas).FormulaHidden = True .Protect myPassword End With Next mySheet On Error GoTo 0 Application.ScreenUpdating = True End Sub هذا كود فك الحمايه Sub Protec() ' قبل وضع الكود ... 'لابد من جعل الخلايا كلها 'unlocked 'حدد خلايا ورقة العمل بالكامل 'ثم كليك يمين ثم اختار آخر تبويب 'ثم أزيل علامة الصح بجانب الخيار 'Lock وكذلك Hidden '================= Application.ScreenUpdating = False Dim mySheet As Worksheet Dim myPassword As String With Application .DisplayFullScreen = False .CommandBars("Worksheet Menu Bar").Enabled = True .CommandBars("Standard").Visible = True .CommandBars("Formatting").Visible = True .DisplayFormulaBar = True .DisplayStatusBar = False End With myPassword = "" On Error Resume Next For Each mySheet In ActiveWorkbook.Sheets With mySheet .Unprotect myPassword .Cells.Locked = False .Cells.SpecialCells(xlCellTypeFormulas).Locked = True .Cells.SpecialCells(xlCellTypeFormulas).FormulaHidden = True .Protect myPassword End With Next mySheet On Error GoTo 0 Application.ScreenUpdating = True End Sub

كلام سليم استاذ ابو احمد ..فحينما اخذ اجازة ليوم واحد ..تكتب في استمارة الاجازة من 05/01 إلى 05/01. طبعا يجب الانتباه لتلك الامور خاصة في العقود الانشائية الكبيرة ..لان اليوم تأخير عن تسليم العمل فيه غرامات تأخيرية تكلف مبالغ كبيرة وهذه الجملة جدا مهمة سبقتني في ذكرها ...وهي صادرة عن شخص له خبرة في مجال الادارة والعقود اما بالنسبة لموضوع اخونا العزيز @عبد اللطيف سلوم فأن عقد التاجير يجب ان توضح به عدة جوانب يلتزم بها المستأجر ..والعقد كما يقولون شريعة المتعاقدين وعلى اساس شروط العقد نستطيع بناء قاعدة البيانات .. حينما قلت ان البرنامج يجب ان يكون على الوقت ..فيه جوانب غبن بحق المستأجر ..وهي انه لو تم الاستلام بعد دقيقة فسيحسب عليه يوم كامل ..وهذا مو انصاف ما اقصده ..مثلا يكتب في العقد ..اذا تأتخر الاستلام عن 60 دقيقة فيحسب يوم كامل

كلام الاساتذة صحيح .. اذا كان تاريخ التسليم مثلا الساعة 12 ظهرا من يوم 1/6 ..وتاريخ الاستلام الساعة 12 ظهرا من يوم 5/6 فتكون المدة 4 ايام ..اما اذا تجاوزت بعد ال 12 ظهرا فيحتسب يوم اضافي اعتقد ان الحساب يكون على اساس الوقت افضل ..لان السيارة الموجرة في نفس اليوم ستظهر المدة 0 انظر للحقل totalDay في الاستعلام طبعا بالامكان اختصار الحقول ...لكن للتوضيح test car rent.rar

المعادلة صحيحة طبيعي اذا مثلا طلعت اجازة اليوم ما راح ترجع بنفس اليوم مثلا انت موظف و قدمت على طلب اجازة يوم واحد فقط تبدء من تاريخ : 16/05/2023 ما راح ترجع في نفس اليوم راح ترجع ثاني يوم يعني تاريخ نهاية الإجازة في : 17/05/2023 لكن لو حبيت انها تنتهي في نفس اليوم فقط تقدر تضيف (+1) للمعادة و بتكون الاجازة تبدء و تنتهي في نفس اليوم

السلام عليكم شنو هاي ما شاء الله تسلم

مساعد اخر للمحترم ظفر الله عسكر يحفطه الرحمن الرحيم مساعد الجداول لظفر الله .xlsx

نورت المنتدى استاذ محمدى عبدالسميع

يحفظكم الرحمن الرحيم

احمع عليها واحد الحسبة الصح هي : تاريخ الاستلام - تاريخ التسليم + 1

يحفظكم الرحمن الرحيم

السادة اعضاء المنتدى الأفاضل تم تزويد الملف بالاكواد ويعمل الحمد لله بطريقة جيدة أضعه هنا اذا اراد احد الاستفادة منه Pension2023.xlsm

Try Sub Test() Dim ws As Worksheet, sh As Worksheet, tbl As ListObject, lr As Long, i As Long Application.ScreenUpdating = False With ThisWorkbook Set ws = .Worksheets("Items"): Set sh = .Worksheets("Orders") End With Set tbl = sh.ListObjects(1) lr = tbl.Range.Rows.Count + tbl.Range.Row - 1 Do While sh.Cells(lr, "C").Value = Empty lr = lr - 1 Loop lr = lr + 1 Dim a(1 To 16), e For Each e In Split("H15,F4,F6,H6,F9,H9,J9,F13,H13,J13,F15,J15,F18,H18,J18,F20", ",") i = i + 1 a(i) = ws.Range(e).Value Next e sh.Range("C" & lr).Resize(, 16).Value = a Application.ScreenUpdating = True MsgBox "Done", 64 End Sub

Try Sub Test() Dim lr As Long With ActiveSheet lr = .Cells(Rows.Count, 1).End(xlUp).Row With .Sort .SortFields.Clear .SortFields.Add Key:=Range("F3"), Order:=xlAscending .SortFields.Add Key:=Range("G3"), Order:=xlDescending .SortFields.Add Key:=Range("H3"), Order:=xlAscending .SetRange ActiveSheet.Range("A3:H" & lr) .Header = xlYes .Apply End With End With End Sub