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

السلام عليكم، لو اردنا ان نقوم بحفظ السجلات المحددة في النموذج الفرعي سنلجئ لعمل CheckBox في الجدول ومن ثم نقوم بعمل استعلام يقوم بفلترة جميع الـ Checkbox التي تكون قيمتها True ومن ثم نقوم بحفظها. لكن! ماذا لو كانت قاعدة البيانات تعمل بنظام الشبكة ( Multi Users ) اذا قام المستخدم رقم 1 بوضع علامة صح على مثلا مادة ( برتقال ) وقام المستخدم رقم 2 بوضع علامة صح على مثلا مادة ( رمان ) عندما يضغط اي مستخدم على حفظ البيانات فـ ستحفظ البيانات وتكون النتيجة خاطئة لان البيانات ليست هي المطلوبة انا اخترت ( برتقال ) فأتتني النتيجة ( برتقال + رمان ) وكذا بالنسبة للمستخدم الثاني والثالث وغيرهم، ممن يعملون على قاعدة البيانات بوقت واحد، صراحة واجهتني هالمشكلة لكن وجدت الحل لها كما انني رأيت موضوع للأخ ابا جودي يتكلم عن هذه المشكلة ارفقت لكم طريقة مختلفة في تحديد السجلات وهي الضغط على مُحدد السجلات للأمانة الطريقة ليست كلها من برمجتي الحقوق لـ arnelgp انا فقط قم اضافة وتعديل بعض الامور البسيطة تحياتي لكم RecordSelectorClick.accdb

تم التعديل jAZ_last.xlsm

وعليكم السلام ورحمه الله وبركاته تفضل اخى الكريم Sub File_Save_As() ThisWorkbook.SaveAs Filename:="e:\" & Format(Date, "ddd") & "-" & Format(Date, "dd-mm-yyyy") & "new", FileFormat:=52 End Sub

Try This Macro Option Explicit Dim E As Worksheet Dim O As Worksheet Dim RO%, RE%, i%, col% Dim x1%, x2%, y%, Total% Dim F_rg As Range Dim Where As Range Dim Bol As Boolean '+++++++++++++++++++++++++++++++++++ Sub Begin() Set O = Sheets("ONE") Set E = Sheets("Ehtiag") RO = O.Cells(Rows.Count, 1).End(3).Row col = E.Cells(1, Columns.Count).End(1).Column RE = E.Cells(Rows.Count, 1).End(3).Row Set Where = O.Range("J1:J" & RO) E.Range("C3").Resize(RO - 2, col - 2).Clear End Sub '+++++++++++++++++++++++++++++++++ Sub Ila_al_Amam_Ser() Application.ScreenUpdating = False Begin For i = 3 To RE Set F_rg = Where.Find(E.Range("A" & i), LOOKAT:=1) If Not F_rg Is Nothing Then x1 = F_rg.Row: x2 = x1 Do Bol = IsError(Application.Match(O.Cells(x2, 1), _ E.Cells(1, 1).Resize(, col), 0)) If Not Bol Then y = Application.Match(O.Cells(x2, 1), _ E.Cells(1, 1).Resize(, col), 0) E.Cells(i, y) = "Ok" End If Set F_rg = Where.FindNext(F_rg) x2 = F_rg.Row If x2 = x1 Then Exit Do Loop End If Next i Total = Application.CountA(E.Range("C3").Resize(RE - 2, col - 2)) If Total = 0 Then GoTo Buy_Buy With E.Range("C3").Resize(RE - 2, col - 2) .Borders.LineStyle = 1 With .SpecialCells(2, 23) .Font.Bold = True .Font.Size = 16 .InsertIndent 1 .Interior.ColorIndex = 35 End With End With Buy_Buy: Application.ScreenUpdating = True End Sub File Included happy_0.xlsm

مشاركة مع استاذي العزيز rey360 If IsNull(date1) Then MsgBox "من فضلك ادخل التاريخ" Exit Sub ElseIf IsNull(nam2) Then MsgBox "من فضلك ادخل اسم الفرع" Exit Sub End If DoCmd.GoToRecord , , acNewRec

وعليكم السلام ... يمكنك استخدام هذه المعادلة بالتنسيقات الشرطية =OR(AND(I5=$F5,I5<>""),AND(I5=$G5,I5<>"")) حساب.xlsx

عمل رائع بارك الله فيك استاذ ماجد وزادك الله من فضله

تفضل جرب هذا الملف , يمكنك التعديل عليه كما تشاء UserformKeypad.xls

فقط يمكنك استخدام معادلة المصفوفة (Ctrl+Shift+Enter) =OFFSET($B$10,MAX(ROW(B:B)*(B:B<>0))-10,0) Sheets1.xlsx

بنسخة 365 أى بمقابل مادى

هذا الأمر بسيط جداً وكان أولى ان تقوم بعمله بنفسك ... تم تكبير المدى الى 1500 بالمعادلة 1مخازن 2021.xlsm

تفضل هذا الفيديو به طلبك سيفيدك بما انك لم تقم برفع ملف

وعليكم السلام-تفضل أسماء جميع العاملين بالمدرسة.xlsm

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

طيب ياسيدي لاحظ المرفق .... معليش انا غيرت بعض المسميات للجدول وبعض الحقول لانها محجوزة للاكسس .... بداية : جرب السرعة في الاضافة للسجل بين السجلات وفتح النموذج على السجل المضاف لأضافة الحديث أو المتن المطلوب بعدها نفكر في تحريك السجلات صعودا أو نزولا .... kan_mosnad.accdb

Public Function sii(e As Date, s As Date) As Integer Dim rs As Recordset Dim ss As Integer Set rs = CurrentDb.OpenRecordset("select * from ts WHERE typ=1 and CDbl([datemou])>=" & Replace(CDbl(e), ",", ".") & " and CDbl([datemou])<" & Replace(CDbl(s), ",", ".") & "") rs.MoveLast: rs.MoveFirst Do While Not rs.EOF ss = ss + rs!summ rs.MoveNext Loop MsgBox ss End Function بفضل الله تم التخلص من مشكل الخطىء 3075 و سبب كان الفاصلة بحيث في النسخة الفرنسية تكون الفاصلة على هذا الشكل , و sql لا يفهمها بحيث يجب وضعها على شكل نقطة وهنا نستعين بالدالة replace شكرا لك أستاذ احمد الفلاحجي

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

Dim Reponse% If m <> 0 Then Reponse = MsgBox("الرقم مكرر هل تريد المتابعة: " & Chr(10) & _ Join(arr, " ; "), 524292) If Reponse <> 6 Then Exit Sub End If

جميل تمام التمام تسلم ايدك ربنا ينجيك دائما ربنا يحفظك ويفرحك ويسترك ويكرمك الف الف شكر ربنا يجعل كل ايامك هنا وسرور وسعادة وازهار وكل حاجة جميلة انا مش عارف اشكرك ازى والله ربنا يعزك ما اتحرمش منك ابدا يارب اللهم امين

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

يبدو انك لم لما هو مكتوب هنا : وعلى كل تفضل التعديل حيث يتم العودة للشاشة الرئيسية عند ضغط زر الطباعة مطعم وجبات.rar

السلام عليكم هذا هو المثال و قد استخدمت الكود التالي لعرض الصفوف المحددة على شكل رسائل مع تعديل خاصية متعدد التحديد لمربع القائمة إلى عادي On Error Resume Next Dim i If Me.list_facture.ItemsSelected.Count = 0 Then MsgBox "لم يتم تحديد أي عنصر" Exit Sub End If For Each i In Me.list_facture.ItemsSelected MsgBox Me.list_facture.ItemData(i) Next i تحديد متعدد.mdb

قم بالتعديل كما في الصورة

جرب هذا الكود Option Explicit Sub colorize() Dim lr%, i% Const n = 35 Const Mot = "Saturday" With Sheets("My_sheet") lr = .Cells(Rows.Count, 1).End(3).Row .Range("A1:A" & lr).Interior.ColorIndex = xlNone For i = 1 To lr If .Cells(i, 1) = Mot Then .Cells(i, 1).Interior.ColorIndex = n End If Next End With End Sub الملف مرفق Sayaed.xlsm

السلام عليكم ورحمة الله وبركاته بعد اذن اخوي العزيز سليم .. ملف اكسل .. احتمال كبير ممكن يفيدك في غياب واستئذان وتأخر الطلاب ادخل البيانات المطلوبة في صفحة data .. ادخال الغياب عن طريق رقم الطالب بشكل يومي .. بعد الانتهاء من ادخال الطلاب .. الغائبين .. قم بالضغط على حفظ .. وسوف يتم حفظها في صفحة اخرى .. امكان طباعة تقرير غياب الطلاب .. على شكل كلندر .. بمجرد ادخال رقم الطالب .. والضغط على Update احصائية الغياب لجميع الفصول .. احصائية غياب الطلاب لفصل واحد APSENTSTUDENT.xlsm

الصورة توضح العمل على اليوزر يحب ترتيب الجدول (المربع الأزرق) تصاغدياً 1- بعد ان تعبئة التكس بوكس 1 و 2 وتختار النسبة اضغط على الزر GO jAZZAWI.xlsm

علما انني لم افهم ما تقصده ولكن انظر المرفق ربما هو المطلوب !!! قاعدة.accdb

الشكر لله ثم لاخواننا واساتذتنا جزاهم الله خيرا انا لم يظهر لى اى خطأ ومع ذلك جرب التعديل ده وكذلك لم يظهر اى خطأ وان شاء الله ننتظر تجارب اخواننا واساتذتنا جزاهم الله خيرا Public Function sii(e As Date, s As Date) As Integer Dim rs As Recordset Dim ss As Integer Set rs = CurrentDb.OpenRecordset("select * from ts WHERE typ=1 and CDbl([datemou])>=" & CDbl(e) & " and CDbl([datemou])<" & CDbl(s) & "") rs.MoveLast: rs.MoveFirst Do While Not rs.EOF ss = ss + rs!summ rs.MoveNext Loop MsgBox ss End Function

ممكن تزودنا بمرفق مصغر لما تريد ....

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

زيادة الخير خيرين مع الاعتذار من الأساتذة الذين سبقوني ، فكما يقال : كل الطرق تؤدي إلى روما Sub MissingDatesAdd() Dim dbs As Database Dim rst As Recordset Dim LastDate As Long Dim Rows As Long Dim NewRow As Long Dim Count As Long Set dbs = CurrentDb Set rst = dbs.OpenRecordset("Table1", dbOpenDynaset) rst.Sort = "DAT" Set rst = rst.OpenRecordset With rst .MoveFirst LastDate = !DAT .MoveNext Do While Not .EOF LastDate = LastDate + 1 Rows = CLng(!DAT) If Rows > LastDate Then Rows = Rows - LastDate Count = Count + Rows For NewRow = 1 To Rows .AddNew !DAT = LastDate + NewRow - 1 !Test = "Was missing" .Update Next NewRow LastDate = !DAT End If .MoveNext Loop End With rst.Close Set dbs = Nothing MsgBox "تم إضافة " & Count & " سجلا" End Sub

رائع اخى واستاذى @محمد أبوعبدالله جزاك الله خيرا وهذا الموضوع شبه المطلوب ولكن للاشهر لاخى واستاذى @ابو تراب جزاه الله خيرا والتعديل ليتناسب مع طلب الموضوع Private Sub btnGenerate_Click() Dim rs As DAO.Recordset Dim fromDate As Date Dim toDate As Date Set rs = CurrentDb.OpenRecordset("table1") While Not rs.EOF fromDate = rs("DAT") rs.MoveNext If Not rs.EOF Then toDate = rs("DAT") addMissingMonths fromDate, toDate End If Wend End Sub Public Sub addMissingMonths(ByVal fromDate As Date, ByVal toDate As Date) Dim missingDate As Date Dim missingMonths As Integer Dim i As Integer missingMonths = DateDiff("d", fromDate, toDate) - 1 ' missingMonths = DateDiff("m", fromDate, toDate) - 1 For i = 1 To missingMonths missingDate = DateAdd("d", i, fromDate) ' missingDate = DateAdd("m", i, fromDate) Me.lstMissingMonths.AddItem missingDate DoCmd.SetWarnings False DoCmd.RunSQL "INSERT INTO Table1 ( DAT ) values (" & Format(missingDate, "\#mm\/dd\/yyyy\#") & ");" DoCmd.SetWarnings True Next End Sub يالتوفيق اخوانى

السلام عليكم ورحمة الله وبركاته تفضل اخوي العزيز .. المعادلة =IF(B4="","",CONCATENATE(IF(D4="",$D$3&"-",""),IF(E4="",$E$3&"-",""),IF(F4="",$F$3&"-",""),IF(G4="",$G$3&"-",""),IF(H4="",$H$3&"-",""),IF(I4="",$I$3&"-",""))) BlankCell.xlsx

السلام عليكم ورحمة الله وبركاته جرب الملف .. اختر الملف المراد جلب البيانات منه .. بالضغط على جلب البيانات .. عن طريق الدالة VLOOKUP يفضل اخوي العزيز .. ان يكون البحث برقم الطالب افضل من اسمه .. new.xlsm

السلام عليكم 🙂 نستطيع ان نستورد جدول الوورد الى الاكسس مباشرة : . وهذا الكود يقوم بالعمل: Private Sub cmd_From_Word_Click() ' 'https://bytes.com/topic/access/insights/961343-importing-ms-word-tables-into-ms-access-tables-using-vba ' 'modified by jjafferr, 2021-01-07 ' Dim i As Long Dim myValue As String 'Dim appWord As Word.Application, doc As Word.Document Dim appWord As Object, doc As Object Dim dbs As DAO.Database, rst As DAO.Recordset, strDoc As String Set appWord = CreateObject("Word.Application") 'establish an instance of word strDoc = CurrentProject.Path & "\1322.تحويل أكسس.doc" 'set string to document path and file Set doc = appWord.Documents.Open(strDoc) 'establish the document appWord.Visible = False Set dbs = CurrentDb 'establish the database to use (this is our current Database) Set rst = dbs.OpenRecordset("tbl_From_Word") 'establish the recordset With doc.Tables(1) 'target table 1 in People.docx For i = 1 To .Rows.Count 'cycle through rows in Tables(1) [we skip the first row because the table has headers] With rst .AddNew 'creating a new record myValue = doc.Tables(1).Cell(i, 1).Range.Text ![Col_1] = Replace(Replace(myValue, Chr(13), ""), Chr(7), "") 'remove the extra characters myValue = doc.Tables(1).Cell(i, 2).Range.Text ![Col_2] = Replace(Replace(myValue, Chr(13), ""), Chr(7), "") myValue = doc.Tables(1).Cell(i, 3).Range.Text ![Col_3] = myValue .Update 'update the whole record End With Next 'go to next row in Tables(1) End With rst.Close: Set rst = Nothing 'close and clear recordset dbs.Close: Set dbs = Nothing 'close and clear database doc.Close: Set doc = Nothing 'close and clear document appWord.Quit: Set appWord = Nothing 'close and clear MS Word Me.Requery MsgBox "Done" End Sub . ولا تنسى تغيير اسم ومسار ملف الوورد في المتغير strDoc حسب الوضع في كمبيوترك ، جعفر 1322.تحويل.accdb.zip

وعليكم السلام -لابد وان تكون صياغة المعادلة هكذا =SUMIFS(حركة_مخازن!$A$5:$A$3000,حركة_مخازن!$D$5:$D$3000,$E6,حركة_مخازن!$F$5:$F$3000,$H$4,حركة_مخازن!$M$5:$M$3000,$J$4)

الحمد لله وشكراً لك

تفضل جرب الملف هكذا راتب التعويض .xlsm

السلام عليكم الأمر بكل بساطة لا يوجد به خطأ فقط كان عليك جعل تنسيق هذه الخلية هكذا -تفضل [h]:mm sum attendance1.xls

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

بارك الله فيك استاذ سليم وبعد اذن حضرتك ولإثراء الحل بالمعادلات العادية -تفضل نسب وشرائح.xlsx

لديك حق استاذى الكريم سليم فنبهنا كثيراً جداً على ضرورة رفع ملف بالمشاركة ولكن بعد اذن حضرتك -يمكنك استخدام الكود هكذا , فكان عليك وضع جملة End If بالكود ثلاثة مرات أخرى قبل كلمة Next كما ترى Sub AAD_ASD() Dim R As Integer, M As Integer, N As Integer, O As Integer, p As Integer, Q As Integer, S As Integer, T As Integer Sheets("كهرباء").Range("A4:DZ1000").ClearContents Sheets("ميكانيكا").Range("A4:DZ1000").ClearContents Sheets("نجارة أثاث").Range("A4:DZ1000").ClearContents Sheets("زخرفة").Range("A4:DZ1000").ClearContents Sheets("صحي").Range("A4:DZ1000").ClearContents Sheets("إنشاءات").Range("A4:DZ1000").ClearContents Sheets("تشطيبات").Range("A4:DZ1000").ClearContents M = 4: N = 4: O = 4: p = 4: Q = 4: S = 4: T = 4 Application.ScreenUpdating = False For R = 4 To 1000 If Cells(R, 4) = "كهرباء" Then Range("A" & R).Resize(1, 115).Copy Sheets("كهرباء").Range("A" & M).PasteSpecial xlPasteValues Sheets("كهرباء").Range("A" & M).PasteSpecial xlPasteFormats Application.CutCopyMode = False M = M + 1 ElseIf Cells(R, 4) = "ميكانيكا" Then Range("A" & R).Resize(1, 115).Copy Sheets("ميكانيكا").Range("A" & N).PasteSpecial xlPasteValues Sheets("ميكانيكا").Range("A" & N).PasteSpecial xlPasteFormats Application.CutCopyMode = False N = N + 1 ElseIf Cells(R, 4) = "نجارة أثاث" Then Range("A" & R).Resize(1, 115).Copy Sheets("نجارة أثاث").Range("A" & O).PasteSpecial xlPasteValues Sheets("نجارة أثاث").Range("A" & O).PasteSpecial xlPasteFormats Application.CutCopyMode = False O = O + 1 ElseIf Cells(R, 4) = "زخرفة" Then Range("A" & R).Resize(1, 115).Copy Sheets("زخرفة").Range("A" & p).PasteSpecial xlPasteValues Application.CutCopyMode = False p = p + 1 If Cells(R, 4) = "صحي" Then Range("A" & R).Resize(1, 115).Copy Sheets("صحي").Range("A" & Q).PasteSpecial xlPasteValues Sheets("صحي").Range("A" & Q).PasteSpecial xlPasteFormats Application.CutCopyMode = False Q = Q + 1 If Cells(R, 4) = "إنشاءات" Then Range("A" & R).Resize(1, 115).Copy Sheets("إنشاءات").Range("A" & S).PasteSpecial xlPasteValues Sheets("إنشاءات").Range("A" & S).PasteSpecial xlPasteFormats Application.CutCopyMode = False S = S + 1 If Cells(R, 4) = "تشطيبات" Then Range("A" & R).Resize(1, 115).Copy Sheets("تشطيبات").Range("A" & T).PasteSpecial xlPasteValues Sheets("تشطيبات").Range("A" & T).PasteSpecial xlPasteFormats Application.CutCopyMode = False T = T + 1 End If End If End If End If Next MsgBox ("الحمد لله تـــم ترحيل الناجحين و الراسيسن إلى أوراق عمل جديدة ") Application.ScreenUpdating = True End Sub

وعليكم السلام -تم عمل تنسيقات شرطية للمطلوب بهذه المعادلات ... للون الأحمر =COUNTIF($A2:$D2,A2)=2 واللون الأخضر =COUNTIF($A2:$D2,A2)=3 أما اللون البنى فهكذا =COUNTIF($A2:$D2,A2)>=4 التكرار لمرة ومرتين.xlsx

وعليكم السلام فقط يمكتك استخدام هذه المعادلة =INDIRECT("'"&B3&"'!e21") Test1.xlsx

وعليكم السلام-تفضل يمكنك استخدام هذا الكود Sub DeleteRow() Dim r As Long Dim FirstRow As Long Dim LastRow As Long FirstRow = 8 LastRow = Cells(Rows.Count, "I").End(xlUp).Row - 1 For r = LastRow To FirstRow Step -1 If Cells(r, "i") = "VISUALISEUR" Then Rows(r).Delete End If Next r End Sub VISUAL1.xlsm

بالطبع بعد اذن استاذنا الكبير سليم حاصبيا .... بالتأكيد يمكنك هذا من خلال اضافة هذا الكود بأكواد الفورم مع تعديل عرض العمود الذى تريده من داخل الكود Private Sub UserForm_Initialize() With Me.ListBox1 .ColumnWidths = "0;75;100;75;75;75;75;80;75;70" .Width = 700 End With End Sub كما ان هناك طريقة أخرى بدون أكواد وهى كتابة عرض الأعمدة التى تريده من داخل خصائص الليست بوكس ColumnWidths وذلك كما ترى بالصورة

تلوين اسماء الشيتات بضغطة واحدة لاى عدد من الشيتات الفيديو

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

تفضل هذا الكود: Private Sub رقم_الحافظه_DblClick(Cancel As Integer) 'File_Path="C:\Temp" File_Path = Application.CurrentProject.Path & "\" File_Name = Me.رقم_الحافظه & ".pdf" Name_Path = File_Path & File_Name If Dir(Name_Path) <> "" Then Application.FollowHyperlink Name_Path Else MsgBox "File not found." End If End Sub جعفر New Microsoft Office Access Application.zip

السلام عليكم أخي abujak2007 حياك الله شكرا على المساهمة وعلى الإستجابة لطلب الإخوة لو تكرمت تذكر السطور التي عملت عليها تعديل حتى نستفيد