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

طيب جرب هذا <|<><><><><><|> Dim rst As DAO.Recordset Set dbs = CurrentDb date_custom = Date If Len(Me.number_custom & "") <> 0 Then Exit Sub Me.number_custom = Nz(DMax("[number_custom]", "tbl_custom", "year([date_custom])=" & Year(date_custom)), 0) + 1 Set rst = dbs.OpenRecordset("FrmRretsQ") d = Me.number_custom DoCmd.RunCommand acCmdSaveRecord Do Until rst.EOF rst.Edit rst!number_custom = d rst!date_custom = Date rst!emp_company = DYear rst.Update d = d + 1 rst.MoveNext Loop Me.Requery

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

شكرا أستاذي كمال على طارق على الدعم المصنف1.xlsx

السلام عليكم ورحمة الله وبركاته وبها نبدأ @دم الغزال استبدل هذا السطر Application.SendKeys ("{ESC 2}") بهذا السطر Application.CutCopyMode = False وان استمر الخطأ ارفق ملف للعمل عليه

ِAhmed Hemdan بعد ده كله أين الضغط على أفضل إجابة ؟!!!!

جرب مدخلاتك المصنف1.xlsx

وعليكم السلام =IF(B3="ذكر";IF(OR(C3<50;D3<40;E3<20);"راسب";"ناجح");IF(OR(C3<50;D3<40;E3<20);"راسبة";"ناجحة"))

3 N (2) (1).xlsx

تحياتي الخالصة جرب المرفق لعل فيه ما تريد... 3 N (2).xlsx

وعليكم السلام ورحمه الله وبركاته اخي @ابوعلي الحبيب الكود الخاص بك في المشاركه الاولي ليس به اي مشكله لكن تأكد ان المسار الذي تحفظ به الصورة موجود وهذا كود اخر بسيط سوف يقوم بإنشاء المسار ان لم يكن موجود ويحفظ الصورة Option Explicit Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Boolean Sub Export_Range_As_Picture() Dim Ws As Worksheet, StrToFolder2 As String Dim oRng As Range, sPath As String, oChart As ChartObject Set Ws = ActiveSheet Application.ScreenUpdating = False StrToFolder2 = "D:\pic\" MakeSureDirectoryPathExists StrToFolder2 sPath = StrToFolder2 & Ws.Range("a1").Value & "." & "jpg" Set oRng = Ws.Range("A3:H17") oRng.CopyPicture xlScreen, xlPicture Set oChart = Ws.ChartObjects.Add(Left:=0, Top:=0, Width:=oRng.Width * 1, Height:=oRng.Height * 1) With oChart .Activate .Chart.Paste .Chart.Export Filename:=sPath .Delete End With Application.ScreenUpdating = True End Sub

وعليكم السلام تفضل الجمع بشرط على مستوى صف وأعمدة.xlsx

تفضل أخي @elghoultk 🙂 OpenFormFromCombo.accdb

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

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

أرى تعديل عنوان الموضوع إلى : معادلة لحساب التاريخ من 30 يوم في الشهر أو حساب نهاية الخدمة أو أي عنوان يفيد عند البحث مستقبلا ملحوظة دالة الأكسل لا تحسب خطأ وإنما احتياج الأخ أحمد لا يتناسب مع الدالة المرفق يحتوي على كلمة فك حماية الورقة 123 نهاية الخدمة.xlsx

السلام عليكم استاذنا الفاضل محي الدين ابو البشر بارك الله فى حضرتك و متعك بالصحة و العافية و زادك من علمه و فضله الحمد لله الكود يعمل بشكل رائع و هو المطلوب اكرر شكرى لحضرتك

هكذا؟ Sub test() Dim dic1 As Object: Dim dic2 As Object Dim a, b, w, bb Dim i& a = Sheets("فودا").Cells(1).CurrentRegion b = Application.Transpose(Sheets("قاعدة العملاء").Cells(1).CurrentRegion.Columns(2)) bb = Application.Transpose(Sheets("قاعدة العملاء").Cells(1).CurrentRegion.Columns(1)) Set dic1 = CreateObject("scripting.dictionary") Set dic2 = CreateObject("scripting.dictionary") For i = 2 To UBound(a) If (IsNumeric(Application.Match(a(i, 3), b, 0))) Then If Not dic1.exists(a(i, 3)) Then dic1.Add a(i, 3), Array(a(i, 3), bb(Application.Match(a(i, 3), b, 0)), a(i, 7)) Else w = dic1.Item(a(i, 3)) w(2) = w(2) + a(i, 7) dic1.Item(a(i, 3)) = w End If Else If Not dic2.exists(a(i, 3)) Then dic2.Add a(i, 3), Array(a(i, 3), a(i, 2), a(i, 7)) Else w = dic2.Item(a(i, 3)) w(2) = w(2) + a(i, 7) dic2.Item(a(i, 3)) = w End If End If Next With Sheets("رحل") Union(Range(.Cells(3, 1), .Cells(3, 5).End(xlDown)), Range(.Cells(3, 8), .Cells(3, 11).End(xlDown))).ClearContents .Cells(3, 1).Resize(dic1.Count, 3) = Application.Index(dic1.items, 0, 0) .Cells(3, 8).Resize(dic2.Count, 3) = Application.Index(dic2.items, 0, 0) End With End Sub

السلام عليكم و رحمة الله استخدم الكود التالى Sub GetClass() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, Arr As Variant, Temp As Variant, Temp2 As Variant Dim i As Long, j As Integer, Fasl As String Dim Clss As String, p As Integer Set Sh = Sheets("قوائم فصول ") Sh.Range("B12:E46") = "" Sh.Range("I12:L46") = "" Fasl = Sh.Range("L1").Text Clss = Right(Fasl, 1) '----------------------- Select Case Clss Case 1 Set ws = Sheets("البيانات الأساسية الأول") Case 2 Set ws = Sheets("البيانات الأساسية الثاني") Case 3 Set ws = Sheets("البيانات الأساسية الثالث") Case Else End Select LR = ws.Range("D" & Rows.Count).End(3).Row Arr = ws.Range("D7:N" & LR).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) ReDim Temp2(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) '----------------------- For i = 1 To UBound(Arr, 1) If Arr(i, 3) Like Fasl Then p = p + 1 If p <= 35 Then For j = 1 To 4 Temp(p, j) = Arr(i, Choose(j, 1, 1, 10, 11)) Temp(p, 1) = p '----------------------- Next ElseIf p > 35 Then For j = 1 To 4 Temp2(p - 35, j) = Arr(i, Choose(j, 1, 1, 10, 11)) Temp(p - 35, 1) = p Next End If End If Next '----------------------- If p > 0 Then Sh.Range("B12").Resize(p, UBound(Temp, 2)).Value = Temp If p > 35 Then Sh.Range("I12").Resize(p, UBound(Temp2, 2)).Value = Temp2 End Sub

تحياتي تعديل في الملف الثاني... 3 N.xlsx

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

تحياتي تم استعمال الدالة DATEDIF في الملف المرفق مع تصحيح طفيف لخطأ (عدد الأيام) مع التعليل... 3.xlsx

أنا لا أحبذ استخدام نتائج المدد على شكل سنة وشهر ويوم في الحسابات، حيث يصعب الحصول على نتائج دقيقة، والبديل هو حساب المدد بالسنين وأجزاءها العشرية. في المرفق دالتان أحدهما لحساب مدد الشهور كلها 30 يوم والأخرى لمدد الشهور الفعلية وأنا أنصح بالثانية. جرب قد تعجبك وتغير قناعاتك ومن ثم طريقتك في الحساب. PeriodsCalculator_01.xlsm

‏‏‏‏‏‏‏‏‏‏‏‏قاعدة بيانات1.xlsb

3.xlsx

جرب هذا Sub ExportScreenshot() Dim pic_rng As Range Dim ShTemp As Worksheet Dim wbA As Workbook Dim ChTemp As Chart Dim PicTemp As Picture Dim name_jpg As String Dim strPath As String Dim strPathFile As String Dim myFile As Variant Set ShTemp = ActiveSheet Set wbA = ActiveWorkbook Application.ScreenUpdating = False 'تحديد النطاق المطلوب أخذ صورة له Set pic_rng = ShTemp.Range("D2:AR34") Set ShTemp = Worksheets.Add Charts.Add ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name Set ChTemp = ActiveChart pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture ChTemp.Paste Set PicTemp = Selection With ChTemp.Parent .Width = PicTemp.Width + 800 .Height = PicTemp.Height + 350 End With On Error GoTo errHandler 'الحصول على اسم الصورة من الخلية A1 name_jpg = Range("A1").Value & ".jpg" 'الحصول على مجلد المصنف النشط strPath = wbA.Path If strPath = "" Then strPath = Application.DefaultFilePath End If strPath = strPath & "\" strPathFile = strPath & name_jpg ' حدد مجلدًا للملف myFile = Application.GetSaveAsFilename _ (InitialFileName:=strPathFile, _ FileFilter:="jpg Files (*.jpg), *.jpg", _ Title:="حدد المجلد واسم الملف للحفظ") 'التصدير إلى صورة إذا تم تحديد مجلد If myFile <> "False" Then ChTemp.Export Filename:=myFile, FilterName:="jpg" 'رسالة تأكيد الحفظ مع معلومات الملف MsgBox "تم حفظ الصورة: " _ & vbCrLf _ & myFile End If Application.DisplayAlerts = False ShTemp.Delete Application.DisplayAlerts = True Application.ScreenUpdating = True exitHandler: Exit Sub errHandler: MsgBox "تعذر حفظ الصورة" Resume exitHandler End Sub

وعليكم السلام هذا كود أنا مستخدمه في أداة التقويم الدراسي يحفظ الصورة في سطح المكتب عدل فيه حسب احتياجك Sub ExportScreenshot() Dim Path As String Path = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & "Capture.jpg" Dim pic_rng As Range Dim ShTemp As Worksheet Dim ChTemp As Chart Dim PicTemp As Picture Application.ScreenUpdating = False Set pic_rng = Worksheets("ورقة1").Range("D2:AR34") Set ShTemp = Worksheets.Add Charts.Add ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name Set ChTemp = ActiveChart pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture ChTemp.Paste Set PicTemp = Selection With ChTemp.Parent .Width = PicTemp.Width + 800 .Height = PicTemp.Height + 350 End With ChTemp.Export Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & "تقويم اكسل.jpg", Filtername:="jpg" MsgBox "تم حفظ صورة للتقوم على سطح المكتب" & vbNewLine & "تقويم اكسل.jpg" & vbNewLine & " يمكن الاستفادة منها لتكون خلفية لسطح المكتب" & vbNewLine & "لايقاف الرسال أو منع حفظ الصورة حدد الخيار من تبويب صفحة حول", , "التقويم" Application.DisplayAlerts = False ShTemp.Delete Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

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

انا لله وإنا إليه راجعون خبر محزن للتربية والتعليم بمصر والوطن العربي بقلوب مؤمنة بقضاء الله وقدره ننعى إليكم ونعزى أنفسنا فى وفاة المبرمج محمد الشابوري ،، صاحب برنامج المنجز اللهم أدخله برحمتك فسيح جناتك, اللهم أبدله دارا خير من داره وأهلا خيرا من أهله واجعله مع الصديقين والنبيين والشهداء وحسن أؤلئك رفيقـا -اللهم وسع مدخله وغسله بالماء والبرد. جعلك الله من أهل الجنة ...إنه على كل شئ قدير و بالإجابة جدير وإنا لله وإنا اليـه راجعـــــــــون لا حول ولا قوة إلا بالله العلي العظيم انا لله وانا اليه راجعون قال تعالى في كتابه العزيز ( وَلَنَبْلُوَنَّكُمْ بِشَيْءٍ مِنَ الْخَوْفِ وَالْجُوعِ وَنَقْصٍ مِنَ الْأَمْوَالِ وَالْأَنْفُسِ وَالثَّمَرَاتِ وَبَشِّرِ الصَّابِرِينَ * الَّذِينَ إِذَا أَصَابَتْهُمْ مُصِيبَةٌ قَالُوا إِنَّا لِلَّهِ وَإِنَّا إِلَيْهِ رَاجِعُونَ * أُولَئِكَ عَلَيْهِمْ صَلَوَاتٌ مِنْ رَبِّهِمْ وَرَحْمَةٌ وَأُولَئِكَ هُمُ الْمُهْتَدُونَ )

اللهم غفر له وارحمه

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

البقاء لله وحده ربنا يرحمه ويغفر له ويسكنه فسيح جناته ويلهم أهله وذويه الصبر والسلوان وانا لله وانا اليه راجعون

انا لله وانا اليه راجعون البقاء لله ونسأل الله أن يغفر له ويرحمه ويسكنه فسيح جناته ويلهم أهله وذويه الصبر والسلوان

السلام عليكم رجاء استخدام خاصية البحث في المنتدى قبل طرح السؤال 🙂 اليك الروابط https://cse.google.ae/cse?cx=partner-pub-4958585055085854:7791406915&ie=UTF-8&q=استخراج+بيانات+من+الرقم+القومي&sa=Search يغلق

شكرا جزيلا يا ابو أحمد وبارك الله فيك