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

وعليكم السلام و رحمة الله و بركاته تفضل المطلوب في المرفق VV.accdb

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

أقدم كل التهاني والتبريكات لجميع منتسبي منتدانا الحبيب وكل المسلمين بجميع انحاء العالم بعيد الفطر المبارك .. أعاده الله علينا وعليكم بالخير واليمن والبركات .

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

اجابتك تم اختيارها كأفضل إجابة أو لم يتم ، و لكن ولا اجابتك يخلو أفضلية استاذ @Foksh ماشاء الله عليك اخيرا جئت بحل سؤال الأخير خاصتا دالة Clng كانت ضائعة مني من يومين ابحث في ملفاتي و الحين وجدتها في مشاركتك الكريمة و بارك الله فيك دايما الى الامام.

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

بعد تجربة الإقتراح الذي تم اختياره من قبل أستاذنا @أبوبسمله على عدة تنسيقات للتاريخ كانت النتيجة أنه لا يقوم بالمهمة المطلوبة عند اختلاف تنسيق التاريخ حسب النظام . المقترح التالي هو :- Dat = DateAdd("m", i, Me.Month_From) rst.FindFirst "[Payment_Month]=" & CLng(Dat) لماذا هذا الكود أدق ؟ يستخدم Date مباشرة دون تحويله إلى نص ، مما يضمن أن آكسيس يفهمه كتاريخ وليس كنص قد يسبب أخطاء CLng(Dat) يحول التاريخ إلى الرقم التسلسلي الداخلي الذي يخزنه آكسيس ، مما يزيل أي مشاكل تتعلق بالتنسيق لا يعتمد على إعدادات النظام ( سواءً كان mm/dd/yyyy أو dd/mm/yyyy ) ، لأن آكسيس يخزن التواريخ كأرقام وليس كنصوص لذا قمت بالبحث والتمحيص بأكثر من أسلوب وعدم اعتمادي للكود المقترح من طرف أستاذنا القدير أبو بسمله دون تجربة متعددة الخيارات ؟؟ لماذا الكود التالي أقل دقة ؟ Dat = Format(DateAdd("m", i, Me.Month_From), "yyyy-mm-dd") rst.FindFirst "[Payment_Month]=" & Format$(Dat, "\#mm\/dd\/yyyy\#") Format(DateAdd(...), "yyyy-mm-dd") يحوّل التاريخ إلى نص ، آكسيس لا يتعامل مع "yyyy-mm-dd" كتاريخ افتراضياً ، مما قد يؤدي إلى أخطاء عند البحث Format$(Dat, "\#mm\/dd\/yyyy\#") يحاول فرض التنسيق ، لكنه يعمل فقط إذا كانت الإعدادات الإقليمية للنظام متوافقة معه إذا كان النظام يستخدم dd/mm/yyyy ، فقد يفشل البحث بسبب اختلاف ترتيب اليوم والشهر يعتمد على إعدادات النظام ، مما قد يجعله غير متوقع في بعض الأجهزة 📌 النتيجة النهائية :- ✅ الكود الذي اقترحته حالياً (CLng(Dat)) أكثر دقة لأنه يعتمد على القيم الرقمية للتواريخ في آكسيس ❌ الكود المقترح سابقاً أقل موثوقية لأنه يعتمد على تحويل التاريخ إلى نص وقد يتأثر بإعدادات النظام 💥 وباختصار شديد :- استخدام CLng(Dat) أفضل لأنه :- يتعامل مع التاريخ كقيمة رقمية داخلية (Serial Date) يتجنب مشاكل تنسيق التاريخ المرتبطة بالإعدادات الإقليمية أكثر كفاءة في الأداء لأنه يقارن أرقام وليس نصوص يعكس طريقة تخزين آكسيس الفعلية للتواريخ داخلياً استخدام Format أقل دقة لأنه :- يحول التاريخ إلى نص (string) يعتمد على الإعدادات الإقليمية للنظام قد يسبب أخطاء عند اختلاف تنسيق التاريخ بين الأنظمة يحتاج إلى معالجة إضافية للتأكد من صحة التنسيق 📛 ملاحظة :- انا لا أبحث عن أفضل إجابة بقدر ما أبحث عن حل لمشكلة من جميع النواحي 😊 تأجيل الاقتطاع.zip

العفو أخي الكريم يسعدنا أننا إستطعنا مساعدتك إليك طريقة أخرى مع إظافة التنسيقات يمكنك إختيار ما يناسبك Option Explicit Sub Extract_Names2() Dim dict As Object, ColA As Range, ColB As Range, a As Variant, b As Variant Dim tbl As String, Key As Variant, ColE As Long, début As Long, lr As Long, tmp As Range Dim dCount As Long, UniCount As Long, i As Long, Irow As Long, AutoFilterWasOn As Boolean Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") With Application: .ScreenUpdating = False: .Calculation = xlCalculationManual: End With AutoFilterWasOn = CrWS.AutoFilterMode If AutoFilterWasOn Then CrWS.AutoFilterMode = False lr = Application.WorksheetFunction.Max(CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row, _ CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row) With CrWS.Range("D2:E" & CrWS.Rows.Count) .ClearContents: .Borders.LineStyle = xlNone End With Set dict = CreateObject("Scripting.Dictionary"): dict.CompareMode = vbTextCompare Set ColA = CrWS.Range("A3:A" & lr): Set ColB = CrWS.Range("B3:B" & lr) For Each tmp In ColB tbl = tmp.Value If Not dict.exists(tbl) Then dict.Add tbl, 1 Else dict(tbl) = dict(tbl) + 1 Next tmp début = 3: dCount = 0 For Each tmp In ColA tbl = tmp.Value If dict.exists(tbl) Then CrWS.Cells(début, 4).Value = tbl CrWS.Cells(début, 5).Value = tbl dict.Remove tbl: début = début + 1: dCount = dCount + 1 End If Next tmp ColE = Application.WorksheetFunction.Max(début, CrWS.Cells(Rows.Count, 5).End(xlUp).Row + 1) UniCount = 0 For Each Key In dict.Keys CrWS.Cells(ColE, 5).Value = Key ColE = ColE + 1: UniCount = UniCount + 1 Next Key CrWS.Range("D2").Value = "عدد الوظائف المتشابهة: " & dCount & " | عدد الوظائف الفردية: " & UniCount CrWS.Columns("D:E").AutoFit On Error Resume Next CrWS.Range("D3:E" & CrWS.UsedRange.Rows.Count).FormatConditions.Delete On Error GoTo 0 With CrWS.Range("D3:E" & CrWS.UsedRange.Rows.Count) .FormatConditions.Add Type:=xlExpression, _ Formula1:="=AND(D3<>"""", COUNTIF($D$3:$E$" & .Rows.Count & ", D3)>1)" .FormatConditions(1).Font.Color = RGB(255, 0, 0): .FormatConditions(1).Interior.Color = RGB(255, 182, 193) End With Irow = Application.WorksheetFunction.Max( _ CrWS.Cells(CrWS.Rows.Count, "D").End(xlUp).Row, CrWS.Cells(CrWS.Rows.Count, "E").End(xlUp).Row) a = CrWS.Range("D3:D" & Irow).Value: b = CrWS.Range("E3:E" & Irow).Value For i = 1 To UBound(a, 1) If a(i, 1) <> "" Then With CrWS.Cells(i + 2, 4).Borders .LineStyle = xlContinuous: .Weight = xlThin: .ColorIndex = xlAutomatic End With End If If b(i, 1) <> "" Then With CrWS.Cells(i + 2, 5).Borders .LineStyle = xlContinuous: .Weight = xlThin: .ColorIndex = xlAutomatic End With End If Next i With Application: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: End With End Sub Book2 v4.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته أخي @M.Elmahmoudy رغم أن طلبك غير واضح تماما بالنسبة لي لاكن بعد معاينة الملف على حسب ما فهمت أعتقد أن الحل الأمثل لتنفيد طلبك هو إستخدام الأكواد لأنها سوف تضمن لك الدقة في النتائج والسرعة في التنفيد لأن المعادلات غير قادرة على تنفيذ جميع الوظائف بنفس الكفاءة خصوصا عند التعامل مع قوائم غير مرتبة وتكرار القيم ونطاقات غير المتساوية ولا ربما صفوف مخفية عند تنفيد الفرز على عمود معين زيادة على بطئ ملحوظ في الأداء عند وجود بيانات كبيرة يمكنك تجربة هدا وإذا كنت بحاجة إلى أي تعديلات إضافية يمكنني محاولة مساعدتك في ذلك Option Explicit Sub Extract_Names() Dim dict As Object, début As Long, lr As Long, tmp As Range, AutoFilterWasOn As Boolean Dim dCount As Long, UniCount As Long, ColA As Range, ColB As Range Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") With Application .ScreenUpdating = False: .Calculation = xlCalculationManual End With AutoFilterWasOn = CrWS.AutoFilterMode If AutoFilterWasOn Then CrWS.AutoFilterMode = False lr = Application.WorksheetFunction.Max(CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row, _ CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row) Set dict = CreateObject("Scripting.Dictionary") Set ColA = CrWS.Range("A3:A" & lr): Set ColB = CrWS.Range("B3:B" & lr) For Each tmp In ColB If Not dict.exists(tmp.Value) Then dict.Add tmp.Value, tmp.Row Next tmp CrWS.Range("C2:C" & CrWS.Cells(CrWS.Rows.Count, 3).End(xlUp).Row).ClearContents début = 3: dCount = 0: UniCount = 0 For Each tmp In ColA If dict.exists(tmp.Value) Then CrWS.Cells(début, 3).Value = tmp.Value & " / " & CrWS.Cells(dict(tmp.Value), 2).Value dict.Remove tmp.Value début = début + 1 dCount = dCount + 1 End If Next tmp For Each tmp In ColB If dict.exists(tmp.Value) Then CrWS.Cells(début, 3).Value = tmp.Value début = début + 1 UniCount = UniCount + 1 End If Next tmp CrWS.Range("C2").Value = " عدد الوظائف / المتشابهة: " & dCount & " & الفردية: " & UniCount CrWS.Columns("C:C").EntireColumn.AutoFit Set dict = Nothing With Application .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub Book2 v2.xlsb

Dim Sh As Boolean Public Property Get f() As Worksheet Set f = Sheets("Sheet1") <========= إسم ورقة العمل المرغوب جلب إسم المصنف الجديد منها End Property Private Sub UserForm_Initialize() Dim WS As Worksheet, CrWS As Variant, i As Integer ' قم بتعديل أسماء أوراق العمل المرغوب إظهارها CrWS = Array("Sheet1", "Sheet2", "Sheet3") For Each WS In ThisWorkbook.Worksheets For i = LBound(CrWS) To UBound(CrWS) If WS.name = CrWS(i) Then ListBox1.AddItem WS.name Exit For End If Next i Next WS HideBar Me End Sub Private Sub CommandButton1_Click() Dim i As Integer, ShName As String, newWb As Workbook, sPath As String Dim tmps As Integer, shArr As String, sCount As Integer, WBname As String WBname = f.[R2].Value <======= قم بتعديل عنوان خلية الإسم بما يناسبك If WBname = "" Then: MsgBox "الرجاء إدخال إسم المصنف ", vbExclamation, "إنتباه": Exit Sub 'Code........ .............. End Sub Private Sub CommandButton2_Click() On Error GoTo SupApp Dim arr As New Collection, TempWb As Workbook, WS As Worksheet Dim i As Integer, sMsg As Integer, tbl As Boolean Dim WBname As String, sPath As String, shArr As String WBname = Trim(f.Range("R2").Value) If WBname = "" Then MsgBox "الرجاء إدخال اسم المصنف", vbExclamation, "تنبيه": Exit Sub tbl = Me.CheckBox1.Value For i = 0 To Me.ListBox1.ListCount - 1 If tbl Or Me.ListBox1.Selected(i) Then arr.Add Me.ListBox1.List(i) shArr = shArr & Me.ListBox1.List(i) & "- " sMsg = sMsg + 1 End If Next If sMsg = 0 Then MsgBox "الرجاء تحديد ورقة عمل واحدة على الأقل", vbExclamation, "تنبيه": Exit Sub If Len(shArr) > 0 Then shArr = Left(shArr, Len(shArr) - 2) End If If MsgBox("هل أنت متأكد أنك تريد حفظ الأوراق التالية؟" & _ vbNewLine & vbNewLine & shArr, vbYesNo + vbQuestion, "PDF" & " تأكيد الحفظ") = vbNo Then Exit Sub With Application .ScreenUpdating = False: .EnableEvents = False: .DisplayAlerts = False: .Calculation = xlCalculationManual End With Set TempWb = Workbooks.Add(xlWBATWorksheet) For i = 1 To arr.Count ThisWorkbook.Sheets(arr(i)).Copy After:=TempWb.Sheets(TempWb.Sheets.Count) Next sPath = ThisWorkbook.path & "\" & WBname & ".pdf" If Dir(sPath) <> "" Then Kill sPath TempWb.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False TempWb.Close False MsgBox "تم حفظ الملفات بنجاح", vbInformation, "PDF حفظ" Unload Me CleanUp: With Application .ScreenUpdating = True: .EnableEvents = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic End With Exit Sub SupApp: On Error Resume Next: If Not TempWb Is Nothing Then TempWb.Close False Resume CleanUp End Sub تصدير صفحات v3.xlsm

فكرة الكود جميلة ، ولا بأس بها ، سلمت على الفكرة . لي تعقيب واحد على ما أظن من خلال قراءة الكود ... في الجزء التالي :- For Each subFld In fld.SubFolders totalSize = totalSize + GetFolderSize(subFld) Next subFld يتم حجز مساحة في الذاكرة بشكل رهيب جداً ومتكرر بسبب تكرار الإستدعاء = For Each ، وخصوصاً مع المجلدات الكبيرة الحجم !!! وبالتالي سيكون الأداء بطيء جداً عند الإفتراض أن مجلد رئيسي يحتوي 10 مجلدات فرعية - على سبيل المثال - ونريد جلب حجم هذا المجلد ، فأن الكود سيقوم بتخزين الأمر مكرراً 10 مرات في الذاكرة وبالتالي قد ينتج عنه أخطاء إما في جلب البيانات ( حجم المجلد ) أو عدم دقتها ، أو سينتج الخطأ Overflow في نهاية المطاف . كما أنها لا تدعم الإيقاف أو ( ايقاف العملية ) وبالتالي قد تستمر العملية لوقت طويل دون تحكم . وهذه بالنسبة لي الطريقتين التي فهمتهما لاستدعاء الدوال في الكود الذي اقترحته .. 'مثال على مسار مجلد محدد في الكود Sub ExampleGetFolderSize() Dim folderPath As String Dim result As String folderPath = "C:\Intel" result = GetFileInfo( _ inputPath:=folderPath, _ fileType:=ftFolder, _ infoType:=itSizeOnly, _ decimalPlaces:=2 _ ) MsgBox "حجم المجلد: " & result End Sub ' مثال على استخدام مربع حوار لاختيار المجلد Sub ExampleWithFolderPicker() Dim result As String result = GetFileInfo( _ fileType:=ftFolder, _ infoType:=itSizeOnly _ ) If result <> "لم يتم اختيار مجلد" Then MsgBox "حجم المجلد: " & result End If End Sub هذا من وجهة نظري ، ولا أحاول الخروج عن سياق الموضوع .

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

وعليكم السلام ورحمة الله تعالى وبركاته Function NumtoTxt(TheNo As Double, MyCur As String, MySubCur As String) As String Dim txtArr1(0 To 9) As String, txtArr2(0 To 9) As String, txtArr3(0 To 9) As String Dim Myno As String, GetNo As String, RdNo As String, My100 As String, I As Integer Dim My10 As String, My1 As String, My11 As String, My12 As String, GetTxt As String Dim MyAnd As String, Mybillion As String, MyMillion As String, MyThou As String Dim MyHun As String, MyFraction As String, ReMark As String If TheNo > 999999999999.999 Then Exit Function If TheNo < 0 Then TheNo = TheNo * -1: ReMark = "يتبقى لكم " Else ReMark = "" If TheNo = 0 Then NumtoTxt = "صفر": Exit Function MyAnd = " و" txtArr1(0) = "": txtArr1(1) = "مائة": txtArr1(2) = "مائتان": txtArr1(3) = "ثلاثمائة": txtArr1(4) = "أربعمائة" txtArr1(5) = "خمسمائة": txtArr1(6) = "ستمائة": txtArr1(7) = "سبعمائة": txtArr1(8) = "ثمانمائة": txtArr1(9) = "تسعمائة" txtArr2(0) = "": txtArr2(1) = "عشر": txtArr2(2) = "عشرون": txtArr2(3) = "ثلاثون": txtArr2(4) = "أربعون" txtArr2(5) = "خمسون": txtArr2(6) = "ستون": txtArr2(7) = "سبعون": txtArr2(8) = "ثمانون": txtArr2(9) = "تسعون" txtArr3(0) = "": txtArr3(1) = "واحد": txtArr3(2) = "اثنان": txtArr3(3) = "ثلاثة": txtArr3(4) = "أربعة" txtArr3(5) = "خمسة": txtArr3(6) = "ستة": txtArr3(7) = "سبعة": txtArr3(8) = "ثمانية": txtArr3(9) = "تسعة" GetNo = Format(TheNo, "000000000000.000") I = 0 Do While I < 15 If I < 12 Then Myno = Mid$(GetNo, I + 1, 3) ElseIf I = 12 Then Myno = Mid$(GetNo, I + 2, 3) End If If Val(Myno) > 0 Then RdNo = Mid$(Myno, 1, 1): My100 = txtArr1(Val(RdNo)) RdNo = Mid$(Myno, 3, 1): My1 = txtArr3(Val(RdNo)) RdNo = Mid$(Myno, 2, 1): My10 = txtArr2(Val(RdNo)) If Mid$(Myno, 2, 2) = "11" Then My11 = "إحدى عشر" If Mid$(Myno, 2, 2) = "12" Then My12 = "اثنا عشر" If Mid$(Myno, 2, 2) = "10" Then My10 = "عشرة" If Val(Mid$(Myno, 1, 1)) > 0 And Val(Mid$(Myno, 2, 2)) > 0 Then My100 = My100 + MyAnd If Val(Mid$(Myno, 3, 1)) > 0 And Val(Mid$(Myno, 2, 1)) > 1 Then My1 = My1 + MyAnd GetTxt = My100 + My1 + My10 If Val(Mid$(Myno, 3, 1)) = 1 And Val(Mid$(Myno, 2, 1)) = 1 Then GetTxt = My100 + My11: If Val(Mid$(Myno, 1, 1)) = 0 Then GetTxt = My11 End If If Val(Mid$(Myno, 3, 1)) = 2 And Val(Mid$(Myno, 2, 1)) = 1 Then GetTxt = My100 + My12: If Val(Mid$(Myno, 1, 1)) = 0 Then GetTxt = My12 End If If I = 0 And GetTxt <> "" Then If Val(Myno) > 10 Then Mybillion = GetTxt + " مليار" Else Mybillion = GetTxt + " مليارات" If Val(Myno) = 1 Then Mybillion = "مليار" If Val(Myno) = 2 Then Mybillion = "ملياران" End If If I = 3 And GetTxt <> "" Then If Val(Myno) > 10 Then MyMillion = GetTxt + " مليون" Else MyMillion = GetTxt + " ملايين" If Val(Myno) = 1 Then MyMillion = "مليون" If Val(Myno) = 2 Then MyMillion = "مليونان" End If If I = 6 And GetTxt <> "" Then If Val(Myno) > 10 Then MyThou = GetTxt + " ألف" Else MyThou = GetTxt + " آلاف" If Val(Mid$(Myno, 3, 1)) = 1 Then MyThou = "ألف" If Val(Mid$(Myno, 3, 1)) = 2 Then MyThou = "ألفان" End If If I = 9 And GetTxt <> "" Then MyHun = GetTxt If I = 12 And GetTxt <> "" Then MyFraction = GetTxt End If I = I + 3 Loop If Mybillion <> "" Then If MyMillion <> "" Or MyThou <> "" Or MyHun <> "" Then Mybillion = Mybillion + MyAnd If MyMillion <> "" Then If MyThou <> "" Or MyHun <> "" Then MyMillion = MyMillion + MyAnd If MyThou <> "" Then If MyHun <> "" Then MyThou = MyThou + MyAnd If MyFraction <> "" Then If Mybillion <> "" Or MyMillion <> "" Or MyThou <> "" Or MyHun <> "" Then NumtoTxt = ReMark & Mybillion & MyMillion & MyThou & MyHun & " " & MyCur & MyAnd & MyFraction & " " & MySubCur Else NumtoTxt = ReMark & MyFraction & " " & MySubCur End If Else NumtoTxt = ReMark & Mybillion & MyMillion & MyThou & MyHun & " " & MyCur End If End Function تعديل المبلغ - فلس V2.xlsm

طيب اليكم المرفق الاخيـــــــــــــــــــر المميزات : الاعتماد الكامل على الرقم القومى دوال منفصلة لسهولة استدعائها فى استعلام من خلال الرقم القومى يتم استخراج الجنس/النوع استخراج مكان الميلاد استخراج تاريخ الميلاد حساب العمر بالسنوات حساب العمر بالأشهر حساب العمر بالأيام بناء على حقل تاريخ الميلاد المستخرج من الرقم القومى يتم عمل التالى حساب تاريخ التقاعد حساب سن التقاعد السنوات المتبقيه للتقاعد الاشهر المتبقيه للتقاعد الايام المتبقيه للتقاعد افتح الاستعلام فى القاعده والذى يحمل الاسم : qryAllInfoFromNationalID المرونة المطلقه فقط عند نقل الوحدات النمطية الى اى قاعدة بيانات عمل استعلام وفقط تغير اسم الحقل الخاص بالرقم القومى تبعا للمسمى الموجود فى الجدول الخاص بكم والملون هنا باللون الاحمر BirthDateFromNationalID: GetBirthDateFromNationalID([Emp_NationalID]) وباقى حقول الاستعلام جميعا تعتمد على هذا الحقل لذلك يتم نقلها كما هى ولكن ولكن ولكن لا تغير اسم الحقل : BirthDateFromNationalID لان هذا الاسم تعتمد باقى وكل الحقول الاخرى عليه اعتقد بهذا المرفق يكون الموضوع قتل بحثا وتم عمل كل ما يمكن فيه ويمكن وبكل سهولة ومرونة الان استخدام الحقول المناسبه حسب الحاجه داخل التقارير او النماذج بكل بساطه تم اضافة : نموذج : frmAllInfoFromNationalID تقريــر : rptAllInfoFromNationalID مصدر بيانات كل منهما الاستعلام : qryAllInfoFromNationalID اما النموذج : frmEmployees مصدر بياناته هو الجدول مباشرة الان القاعده كاملة و متكاملة مع تحقيق أقصى درجات المرونه المطلقة والحصول على كل البيانات الممكنه من خلال الرقم القومى مباشره سن التقاعد (8).accdb

بنسبة ملف الأول خانة جرامات : MOD( SUM(C3:C53), 1000) كسور حقل C بعد تجميع و تقسيم على 1000 و خانة كيلوات: SUM(D3:D53)+INT(SUM(C3:C53)/1000) تجميع حقل D + عدد صحيح ، تجميع حقل C و تقسيمه على 100 و الملف الثاني : تم دمج خانتين ومعادلة: تجميع حقل C + تجميع حقل D

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

تقصد دماغى واللا دماغك انت ؟. انا عن نفسي عمرها ما تعمل error لان مفيش دماغ اساسا

لقد تم الإعتماد مسبقا على الكود الأول والدي كان يتضمن وضع الفواصل بعد كلمة Sum تفضل أخي تم تعديل الكود ليتناسب مع طلبك لحفظ الصفحات في مجلد في نفس مسار المصنف بصيغة PDF جرب هدا Option Explicit Sub Save_PDF() On Error GoTo SupApp Dim WS As Worksheet, sPath As String, sFolder As String Dim count As Long, lastRow As Long, cell As Range, début As Integer Set WS = Sheets("test") lastRow = WS.Cells(WS.Rows.count, "B").End(xlUp).Row début = 1: count = 0 For Each cell In WS.Range("B2:B" & lastRow) If InStr(cell.Value, "المجموع") > 0 Then count = count + 1 Next cell If count > 0 Then If MsgBox("هل ترغب بحفظ الصفحات من " & début & " إلى " & count & "؟", _ vbYesNo + vbExclamation, "تأكيد") = vbNo Then Exit Sub sFolder = ThisWorkbook.Path & "\ملفات PDF" If Dir(sFolder, vbDirectory) = "" Then MkDir sFolder sPath = sFolder & "\" & "Page_" & début & "-" & count & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, FileName:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False MsgBox "تم حفظ الملف بنجاح", vbInformation End If SupApp: Set WS = Nothing End Sub تحديد عدد صفوف للصفحة ومجموعها -v3.xlsm للتنفيد على مصنف خارجي.rar Test PDF.pdf

وعليكم السلام ورحمة الله تعالى وبركاته يجب أولا التأكد من عدم تعطيل وحدات الماكرو بسبب أمان الملفات أغلق الملف ثم انقر بزر الماوس الأيمن على خصائص <------ إلغاء الحظر (Unblock) أعد فتح الملف وحاول تشغيل الماكرو التالي Sub OECUE1() Dim WS As Worksheet Dim début As Integer, fin As Integer Set WS = Sheets("haneen") If Not IsNumeric(WS.[H2].Value) Or Not IsNumeric(WS.[U2].Value) Then Exit Sub début = WS.[H2].Value: fin = WS.[U2].Value If début < 1 Or fin < 1 Or début > fin Then Exit Sub If MsgBox("هل ترغب في تنفيذ الطباعة؟", vbYesNo + vbExclamation, "التأكيد") = vbNo Then Exit Sub Application.ScreenUpdating = False Do While début <= fin WS.PrintOut Copies:=1, Collate:=True If début < fin Then WS.[H2].Value = début + 1 début = début + 1 Loop Application.ScreenUpdating = True End Sub الطباعة.rar

تم الحل شكرا

آمين و إياك

تفضل أخي @خير الايمان طلبك . تم اضافة الحقل (Abs)الي الاستعلام (PageNumberCalc) بشرط (is null) ثم تشغيل الزر بالفورم (Form1) ... ثم التقرير (Report1) . ووافني بالرد . QQ_3-1.rar

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

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

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

يجعل ايامك كلها فرح عن فرح يارب قال رسول الله ﷺ : والله في عون العبد ما كان العبدُ في عون أخيه

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

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

🤨

الشكر لله ثم لاخى العزيز @Foksh فالكود كوده وهو من اجابك فعليا والاشكاليه المعروفه والتى هى مصدر المتاعب فعليا التواريخ وتنسيقاتها ولذلك يوجد وحده نمطيه للخروج من هذه الاشكاليه قد ارفقها اخى واستاذى الغالى @jjafferr جزاه الله عنا كل خير ومن يومها يا بستخدمها يا بستخدم الفورمات منها وسوف ارفق الرابط لها التعديل على السطر التالى rst.FindFirst "[Payment_Month]=#" & Dat & "#" الى rst.FindFirst "[Payment_Month]=" & Format$(Dat, "\#mm\/dd\/yyyy\#") والرابط التالى للمتابعه اخى @طاهر اوفيسنا بالنسبه للاشكاليه التى ارفقتها فالتاريخ موجود كما بالصوره فى اصل المرفق الذى قمت بانزاله انا والتعديل عليه والكود ليس له علاقه به لا من قريب ولا من بعيد قم بتنزيل المرفق وتعديل التاريخ الى 1 وجرب مره اخرى واخبرنا وكل عام وانتم بخير

أشكر أخي العزيز @أبوبسمله على جهوده المتميزة 🤗 . وارجو إرفاق الكود هنا للإستفادة بسبب عدم تواجدي أمام الكمبيوتر 😇 .

انت صح وانا بس خليت الكود اكثر مرونه ليعمل مع كل انواع الحقول نص او رقم او تاريخ

استبدل كود الموديول بالكود التالى Public Function Horizontal(tabelle As String, Feld1 As String, Feld2 As String, valFeld1 As Variant) As String Dim DB As DAO.Database Dim rs As DAO.Recordset Dim fieldType As Integer Dim sqlWhere As String Dim first As Boolean ' تعيين قاعدة البيانات الحالية Set DB = CurrentDb ' استرجاع نوع الحقل Feld1 fieldType = DB.TableDefs(tabelle).Fields(Feld1).Type ' تنسيق القيمة بناءً على نوع الحقل Select Case fieldType Case dbText, dbMemo, dbChar ' النصوص: وضع القيمة بين علامات اقتباس مفردة مع معالجة علامات الاقتباس الداخلية sqlWhere = "[" & Feld1 & "]='" & Replace(valFeld1, "'", "''") & "'" Case dbDate, dbTime, dbTimeStamp ' التواريخ: وضع القيمة بين علامات # مع تنسيق التاريخ sqlWhere = "[" & Feld1 & "]=#" & Format(valFeld1, "yyyy-mm-dd hh:nn:ss") & "#" Case dbInteger, dbLong, dbSingle, dbDouble, dbCurrency, dbDecimal ' الأرقام: إدراج القيمة مباشرة sqlWhere = "[" & Feld1 & "]=" & valFeld1 Case Else ' معالجة الأنواع غير المدعومة MsgBox "نوع البيانات غير مدعوم للحقل: " & Feld1, vbExclamation Exit Function End Select ' إنشاء وتنفيذ استعلام SQL Set rs = DB.OpenRecordset("SELECT DISTINCT [" & Feld2 & "] FROM [" & tabelle & "] WHERE " & sqlWhere & " ORDER BY [" & Feld2 & "] DESC") ' تهيئة متغير للسجل الأول first = True ' معالجة السجلات المسترجعة Do While Not rs.EOF If first Then Horizontal = rs(Feld2) ' القيمة الأولى first = False Else Horizontal = Horizontal & vbCrLf & rs(Feld2) ' إضافة القيم التالية مع فاصل سطر End If rs.MoveNext Loop ' تحرير الموارد rs.Close Set rs = Nothing Set DB = Nothing End Function

تفضل المطلوب ولو اردت استخدام دالة IF لإضافة شروط إضافية، مثل عرض "كيلو" فقط إذا كانت الجرامات صفرًا. هذه المعادلة فى السطر 56 =IF(MOD(SUM(E3:E53);1000)=0;INT(SUM(E3:E53)/1000)+SUM(F3:F53)&" كيلو";INT(SUM(E3:E53)/1000)+SUM(F3:F53)&" كيلو و "&TEXT(MOD(SUM(E3:E53);1000);"0")&" جرام") شغل.xlsx

تفضل التعديل . مع ملاحظة اسم حقل الترقيم التلقائي بالجدول والفورم (Borrower's_No) . النسخة المرسلة-1.rar

للأسف لم يعمل

إن شاء الله، جاري تجربة

نرجو من احد الإخوة والاساتذة الذي يمرون من هنا تجربة المرفق واخبارنا بالنتيجة .. تأجيل الاقتطاع.zip

قبل تجهيز النظام للرفع لكم لانشاء نظامكم - خفايف كود موضح في المرفق تجربة ممتعة GiveMe_File_Out_Size_File.rar

بناءً على ما فهمت من المطلوب ، هو اضافة سجلات = عدد الاشهر التي تم تأجيلها ، بشرط ان يتم تأجيل الدفعة ( القيمة ) الى الاشهر الجديدة ؛ صحيح ؟ جرب ها التعديل !!! Private Sub cmd_Do_Changes_Click() Dim rst As DAO.Recordset Dim Dat As Date Dim Remarks As String Dim i As Integer Me.Month_From = DateSerial(Year(Me.Month_From), Month(Me.Month_From), 1) If Me.Month_From < Me.DiscountStartDate Then MsgBox "آسف, شهر التأجيل الذي أدخلته أصغر من شهر بداية الإقتطاع" & vbCrLf & _ "يرجى التصحيح وحاول مرة أخرى" Exit Sub ElseIf Me.Month_From > Me.DiscountEndDate Then MsgBox "آسف, شهر التأجيل الذي أدخلته أكبر من شهر نهاية أخر إقتطاع" & vbCrLf & _ "يرجى التصحيح وحاول مرة أخرى" Exit Sub End If If Me.OpenArgs = "frmCridi" Then MySQL = "Select * From tbl_Loans Where Loan_ID = " & Me.Loan_ID & " And Loan_Type='Cridi'" Loan_Type = "Cridi" r = "" Else MySQL = "Select * From tbl_Loans Where Loan_ID = " & Me.Loan_ID & " And Loan_Type='Elec'" Loan_Type = "Elec" r = "" End If Set rst = CurrentDb.OpenRecordset(MySQL) For i = 0 To Me.Number_Of_Months - 1 Dat = Format(DateAdd("m", i, Me.Month_From), "yyyy-mm-dd") rst.FindFirst "[Payment_Month]=#" & Dat & "#" If Not rst.NoMatch Then Remarks = rst!Remarks rst.Edit rst!Loan_Made = 0 rst!Remarks = Remarks & " | " & "تأجيل الإقتطاع إلى تاريخ " & Format(DateAdd("m", i + 1, Me.DiscountEndDate), "DD-MM-YYYY") rst.Update End If rst.AddNew rst!EmployeeID = Me.EmployeeID rst!Loan_ID = Me.Loan_ID rst!Auto_Date = Me.AwardMonth rst!Payment_Month = DateAdd("m", i + 1, Me.DiscountEndDate) rst!Loan_Made = Me.DiscountPerMonth rst!Loan_Type = Loan_Type rst!Remarks = Remarks rst!annee = Year(Date) rst.Update Next i rst.Close: Set rst = Nothing Forms!frmCridi!Frm_sub!DiscountEndDate = DateAdd("m", Me.Number_Of_Months, Forms!frmCridi!Frm_sub!DiscountEndDate) Forms!frmCridi!Frm_sub!Obsérvation = Forms!frmCridi!Frm_sub!Obsérvation & " | " & _ "تأجيل الإقتطاع لمدة " & GetMoisName(i) I2 = Forms!frmCridi!Frm_sub!ID Forms!frmCridi!Frm_sub.Form.Requery Set rst = Forms!frmCridi!Frm_sub.Form.RecordsetClone rst.FindFirst "[ID]=" & I2 Forms!frmCridi!Frm_sub.Form.Bookmark = rst.Bookmark MsgBox ("تم تأجيل الإقتطاع لمدة " & GetMoisName(i)) DoCmd.Close End Sub تأجيل الاقتطاع.zip

الحمد لله تعالى اشكرك جدا يا صديقى العزيز وسعيد جدا جدا بمرورك واهتمامك

اريد مايكرو لفتح التعديل وفتح الحذف علي النموذج عندى نموذج مانع عنه التعديل والحذف بس عايز لما اضغط علي كنترول + حرف t يفعل خاصيه التعديل في النوذج ولو ضغط علي كنترول + حرف d افعل خاصيه الحذف

وعليكم السلام ورحمة الله تعالى وبركاته.. تقدر تستخدام حدث "On Key Down" في النموذج للتحقق مما إذا كان المستخدم قد ضغط على Ctrl + T أو Ctrl + D ثم تغيير خصائص التعديل والحذف بناءً على ذلك . بس طبعاً لازم تتأكد أن خاصية Key Preview في النموذج = Yes 😅 وإلا فلن نستفيد من الكود التالي :- Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = vbKeyT And (Shift And acCtrlMask) <> 0 Then Me.AllowEdits = True MsgBox "تم تفعيل التعديل", vbInformation End If If KeyCode = vbKeyD And (Shift And acCtrlMask) <> 0 Then Me.AllowDeletions = True MsgBox "تم تفعيل الحذف", vbInformation End If End Sub جرب النتيجة النهائية وأخبرنا بها 😇

كان لى رغبة فى معرفة بديل تنسيق yyyy/mm/dd لاستخدامها فى الحقول الـ Unbound (غير منضم ) وقد رأيتها هنا : Else birthDate = Format(CDate(birthDate), YearMonthDayFormat) ' تحويل المدخل إلى تاريخ currentDate = Format(Date, YearMonthDayFormat) ' تعيين التاريخ الحالي Format YearMonthDayFormat شكراً ابو جودي

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

المرفق هو آخر ملف تم وضعه بمعرفتك المراد أن يكون تنسيق التاريخ فيه : يوم / شهر / سنة فى كل خانة تحتوى عنصر تاريخ أى من اليمين لليسار yyyy/mm/dd سن التقاعد (7).accdb

اتفضل بيانات المدرسين (2).zip

تم التجربة والبرنامج يعمل بلا أخطاء

و عليكم السلام و رحمة الله و بركاته تفضل اليك التعيل إن شاء الله يكن حسب المطلوب test (5).accdb

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