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

لعرض آخر 20 ضف يمكنك تغيير هذا السطر في الاجراء showdata For frw = 4 To last إلى For frw = last - 19 To last ولخذف الصف المطلوب Private Sub CommandButton1_Click() If MsgBox("Are you sure you want to delete this item?", vbYesNo, "Confirm Delete") = vbYes Then Rows(ListView1.SelectedItem.ListSubItems(1).Text + 3).EntireRow.Delete showdata End If MsgBox "Done by mr-mas.com" End Sub بالتوفيق

وبدون عمود مساعد يمكنك استعمال هذه المعادلة في الخلية L25 =IF(L24-L25<0,100,0)+L24-L25 وهذه في M25 =IF(L24-L25<0,-1,0)+M24-M25 بالتوفيق

السلام عليكم ارجو من الخبراء اعطاء تقيم للموضوع يوجد شرح فيديو بسيط https://youtu.be/pQY_Pxch9kM pos WORK.xlsm

الله يفتح عليك أستاذ محمد ويجزيك خير الجزاء ممتاز

تفضل بالتوفيق Dim db As DAO.Database Dim rst As DAO.Recordset Set db = CurrentDb Set rst = Me.RecordsetClone rst.MoveFirst Do Until rst.EOF If rst!ymd = Me.ymd Then MsgBox "تاريخ الغياب مكرر" Cancel = True Exit Do End If rst.MoveNext Loop rst.Close db.Close If rst.EOF Then MsgBox "لا يوجد سجلات" End If

ان شاء الله مش هيكون فى مشكله لما بتكون بالانجليزي الاكسيس هيعرف يتعامل معها بدون مشاكل فلا تشيلى هما (اعتبريه خطأ مني)

يمكن بطرق كثيرة اسهلها البحث والاستبدال CTRL+H ثم تكتب في مربع البحث العملة ومربع الاستبدال يترك فارغا ثم استبدال الكل replace all بالتوفيق

يمكنك البدء في التصميم بعدها تعرض المشكلات التي تواجهها في البرنامج ساعتها تجد الكثير من الزملاء يساعد

شكرا جزيلا على الطرق الجميلة المتنوعة من الأساتذة الكرام

تفضل Dim cal As Integer Dim r As Date Dim i As String cal = Calendar Calendar = 1 r = CDate(hijri.Text) Calendar = 0 i = CStr(r) ymd = Format(i, "YYYY/MM/DD") Calendar = cal التاريخ2.accdb

الطريقة الثانية وهي لا تحتاج الى جدول مؤقت ولا استعلام الحاق فقط امر انشاء استعلام برمجيا بالكود والطريقة تعمل بشكل صحيح جزاك الله وامين لنا ولكم اتفق معكم استاذنا اخونا الشايب

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

الاستاذ @محمد هشام. بارك الله بجهدك و علمك ما شاء الله عليك و على سعة صدرك جزاك الله الجنة

Sub Print_certificates() Dim wb As Workbook, wsData As Worksheet, wsDest As Worksheet Dim fRow, fName As String, MyRng As Range, FndRng As Range Dim Cpt As Range, Linge As String, myValue As String, Question As Integer Set wb = ThisWorkbook: Set wsData = wb.Sheets("Mark All"): Set wsDest = wb.Sheets("Moncer") Set MyRng = wsDest.[A3:I46] myValue = "توقيع ولي الأمر:" Question = MsgBox("طباعة شهادات جميع الطلاب ؟", vbYesNo + vbInformation + vbDefaultButton2, "...تأكيد") If Question = vbYes Then If Len(wsDest.[J1].Value) = 0 Then: MsgBox "المرجوا إدخال إسم الملف", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "إنتباه": Exit Sub Application.ScreenUpdating = False Application.DisplayAlerts = False With model .Visible = xlSheetVisible: .Cells.Clear: .ResetAllPageBreaks End With On Error Resume Next With ActiveWorkbook fFolder = .path & Application.PathSeparator & "شهادات الطلاب" & Application.PathSeparator If Len(Dir(fFolder, vbDirectory)) = 0 Then End If MkDir fFolder On Error GoTo 0 For cList = 9 To wsData.Cells(Rows.Count, "B").End(xlUp).Row cName = wsData.Cells(cList, "B"): wsDest.[B8] = cName wsDest.[T1] = cName: fName = wsDest.[J1] MyRng.Copy With model.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats: .PasteSpecial xlPasteColumnWidths Application.CutCopyMode = False End With Next cList End With With model fRow = .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set FndRng = .Range("A17:A" & fRow) Set Cpt = FndRng.Find(What:=myValue, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext) If Not Cpt Is Nothing Then: Linge = Cpt.Address Do If Not Cpt Is Nothing Then: Cpt.RowHeight = 21: Cpt.Offset(2).PageBreak = xlPageBreakManual: Cpt.Offset(-1).RowHeight = 36 Set Cpt = FndRng.FindNext(Cpt) If Cpt Is Nothing Then: Exit Do If Cpt.Address = Linge Then: Exit Do Loop model.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fFolder & fName & ".pdf" 'قم بتفعيل هداالسطر في حالة الرغبة بطباعة الشواهد ' .PrintOut .Visible = xlSheetVeryHidden End With Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox fFolder & "" & fName, vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, " :تم حفظ شهادات الطلاب بنجاج في" End If End Sub Test13.xlsm

الحمد لله على انقضاء حاجتك وكما ذكر استاذنا انها اسهل طريقة تم استخدام جدول مؤقت واستعلامين ( الحاق وتحديد ) كل هذا من اجل جزء صغير في الفلترة يتبين لنا _ وهي دروس لمن يمر من طلاب العلم _ اهمية الاعتناء بتصميم الجداول ابتداء على الطرق العلمية الصحيحة

لو استطعت جعل الرقم في خلية واحدة سيكون الأمر أسهل ولكن جرب المرفق 🙂 برودروه%20يومية%20الخزينة%20لأعمال%20النقل0000.xlsx

أشكر حضراتكم كثرا وجزاكم الله خيرا على هذا المجهود

مشاركة مع ولدنا الحبيب @عمر ضاحى لم افهم سؤالك الاخير انظر للاستعلام union_IN_OUT.... والاستعلام Monthly_sumQ انا لم اضف شيئا لعمل الاستاذ عمر ..مالم افهمه هو لماذا تريد الحاق البيانات الى جدول اخر ...يمكنك تصفية البيانات حسبما تشاء في تقرير ..حسب الشهر او حسب العيادة JO.rar

طيب ايه. الغرض من رفع الملف

تفضل أخي ... برودروه يومية الخزينة لأعمال النقل0000.xlsx

شكرا لك أخي @عبد اللطيف سلوم .. تقبل الله منك 🙂🌼

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

أستاذ @عبد اللطيف سلوم هدية مقبوله جعلها الله في ميزان حسناتك . 🌹🌹🌹

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي اليك برامج هدية لك ولكل اعضاء وزوار منتدى اوفيسنا . ملف تم تعديله بطريقة دينامكية تمكنك من دمج اكثر من 100 ملف في مجلدات مختلفة في ملف واحد . رابط لشرح طريقة الاستخدام بالتوفيق............ Sh_2023.zip

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي بعد تحميل الملف المضغوط سوف تجد مجلد باسم DATA C قم بنسخه الى القرص ثم افتح ملف سجل القيد وقم باستدعاء البيانات عادي الكود المستخدم Sub MH_data() Application.ScreenUpdating = False Set currentworkbook = ThisWorkbook Set sourceworkbook = Workbooks.Open("C:\DATA\Sheet1.xlsx") sourceworkbook.Worksheets("Sheet1").Range("a2:d500").Copy currentworkbook.Activate currentworkbook.Worksheets("Sheet1").Activate lastcell = Cells(Rows.Count, 2).End(xlUp).Row + 1 currentworkbook.Worksheets("Sheet1").Cells(lastcell, 2).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False sourceworkbook.Close Set sourceworkbook = Nothing Set currentworkbook = Nothing ThisWorkbook.Activate Worksheets("Sheet1").Activate Worksheets("Sheet1").Range("A4").Select Application.ScreenUpdating = True End Sub ملاحظة: يمكنك تغيير مسار الملف من هنا في حالة عدم توفر جهازك على قرص باسم C Set sourceworkbook = Workbooks.Open("C:\DATA\Sheet1.xlsx") سجل القيد_MH.rar

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

سأجيب واحدة واحدة كل هذا مفهوم من الشرح ومن البيانات المرفقة الشيء الجديد هو تخصيص ادخال الدرجات حسب معلم المادة هو مفتوح وقد ذكرت لكم ذلك قاعد البيانات موجودة في مجلد البرامج واسمه school والبرنامج داخله باسم " مدرسة " لفتح القاعدة على التصميم انقري على البرنامج واصبعك على shift نعم يمكن نعم صحيح هذه مكتبة تخص التحكم بالفأرة كإيقاف العجلة ، غير موجودة في جهازك يمكن ايقاف عمل الكود فيتوقف ظهور الرسالة الافضل عدم الاستعجال انما رفعت البرنامج للدراسة والاطلاع وفهم عمل اكسس لمن لم يمارسه والا انت بحاجة اولا الى تصور العمل ( المدخلات والمخرجات ) والجداول اللازمة لذلك اولا التأسيس الصحيح والاساسات هي الجداول اعانك الله ووفقك ،،،

السلام عليكم ... آسف على التأخر بسبب نسياني للموضوع ! :) جرب الدالة التالية التي كتبتها في عجالة : Function ARRAYING(MyRange As Range, Rank As Byte, NumberRow As Long) For i = 1 To Rank If Application.WorksheetFunction.Large(MyRange, i) = Application.WorksheetFunction.Large(MyRange, Rank) Then n = n + 1 End If Next i For Each MyCell In MyRange.Cells If MyCell.Value = Application.WorksheetFunction.Large(MyRange, Rank) Then n1 = n1 + 1 If n1 = n Then ARRAYING = Cells(NumberRow, MyCell.Column).Value Exit Function End If End If Next MyCell End Function Electricity1.zip