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

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

هذه محاولتي 🙂 test (MoosaK).accdb

بالفعل أؤيد هذا الرأي 👍🙂 .. والسبب أنك قد تواجه مشاكل كثيرة عند نقل البرنامج من جهاز إلى آخر .. أو عند تبديل نسخة الأوفيس وتغير الأنوية .. ومشاكل أنت في غنى عنها .. أولها هذه المشكلة التي تعرضها الآن 😅

تجسيداً لفكرة معلمنا الفاضل @ابوخليل ، اعتقد إنها الفكرة الأفضل عند تعدد العملات ،حيث من خلال الإستعلام تستطيع حصر السجلات بشرط نوع العملة . انقر زر نوع العملة لتغييرها هي مجرد فكرة ذات نتائج أفضل عند تراكم السجلات !! test (4).accdb

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

يوجد فكرة قديمة ، وأعتقد الأستاذ @Moosak له تجربة معها ، انظر فكرة الفيديو التالي :-

وعليكم السلام و رحمة الله و بركاته تفضل المطلوب في المرفق 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 هذا من وجهة نظري ، ولا أحاول الخروج عن سياق الموضوع .

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

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي اسم المستخدم : admin كلمة المرور : 1989 Option Compare Text Dim f, Rng, MH(), WS_Rng, DataRng Private Sub UserForm_Initialize() DataRng = "Tableau1" WS_Rng = Range(DataRng).Columns.Count MH = Range(DataRng).Resize(, WS_Rng + 1).Value For i = 1 To UBound(MH): MH(i, WS_Rng + 1) = i: Next i Me.ListBox1.List = MH Me.ListBox1.ColumnCount = WS_Rng + 1 Me.ListBox1.ColumnWidths = "70;110;100;100;100" Me.ComboBox1.List = Application.Transpose(Range(DataRng).Offset(-1).Resize(1)) Me.ComboBox1.ListIndex = 0 Me.B.Caption = "فلترة ب:" & Me.ComboBox1 Set d = CreateObject("scripting.dictionary") For i = 1 To UBound(MH) d(MH(i, 1)) = "" Next i WSdata = d.keys Me.ComboBox2.List = WSdata Sht = Application.Transpose(Range(DataRng).Offset(-1).Resize(1)) For i = 1 To WS_Rng Me("label" & i) = Sht(i, 1) Next i For i = WS_Rng + 1 To 6 Me("label" & i).Visible = False: Me("TextBox" & i).Visible = False Next i Me.ComboBox2 = "*" T_resultat = "عدد الموظفين" & "/" & ListBox1.ListCount + 0 Count = ListBox1.ListCount End Sub '''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Combobox1_click() Me.ListBox1.List = MH Me.B.Caption = "فلترة ب:" & Me.ComboBox1 Me.T.Caption = "بحث ب:" & Me.ComboBox1 Set Titre = Range(DataRng).Offset(-1).Resize(1) colFiltre = Application.Match(Me.ComboBox1, Titre, 0) Set d = CreateObject("scripting.dictionary") For i = 1 To UBound(MH) d(MH(i, colFiltre)) = "" Next i WSdata = d.keys Me.ComboBox2.List = WSdata Me.ComboBox2 = Empty End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub TextBoxRech_Change() On Error Resume Next WSdest = Me.ComboBox1.ListIndex + 1 clé = "*" & Me.TextBoxRech & "*": n = 0 Dim Tbl() For i = 1 To UBound(MH) If MH(i, WSdest) Like clé Then n = n + 1: ReDim Preserve Tbl(1 To UBound(MH, 2), 1 To n) For k = 1 To UBound(MH, 2): Tbl(k, n) = MH(i, k): Next k End If Next i If n > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.clear End Sub منظومة-الشؤون-الادارية.xlsm

بما ان درجات الدور الاول هي مجموع درجات الفصلين قسمة 2 مجموع اعمال الفصلين قسمة 2 المفترض او المنطق يقول : ان النسبة 30% تكون على (مجموع درجات الفصلين قسمة 2 ) ليه تحتسب من درجة اختبار الفصل الثاني؟

الأروع من ذلك شرحك الوافي الدقيق

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

انصحك بالإستعانة بصورة معبرة بدلاً من استخدام مربع النص الخاص الناتج عن ActiveX

احترامي لجميع الاساتذة الكرام اتذكر باني عملت ما يشبه برنامجك منذ فترة طويلة ... طلبك بان تكون العملة في حقل واحد .. يحتاج ان تعمل نموذج بحقول غير مرتبطة ... بحيث عندما تختار دينار يتغير ال caption الى ديتار سأحاول مع ملفك ان وسعني وقتي .. لاني هذه الايام مشغول بالبايثون 😭

هل هذا ما تريده أخي العزيز @Ahmed_J ؟؟

آمين و إياك

ومن قال لك انها بلا مقابل ؟؟؟؟؟؟؟ صدقني جميعنا نبحث في حياتنا عن هذا المقابل 😇

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

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

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

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

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

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

باعتقادي ودون الحاجة الى التوسعات في الإحتمالات ، المشكلة تكمن في السطر التالي :- Dim DB As Database, rs As Recordset بأن يتم التعديل كالتالي :- Dim DB As DAO.Database, rs As DAO.Recordset هذا من وجهة نظري المتواضعة فقط لا غير 😁 . وكل عام وأنتم بخير جميعاً

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

رغم أن هدا لم يكن طلبك في أول مشاركة لاكنني أعتقد أنه الان قد تم تزويدك بجميع الحلول الممكنة للحصول على النتائج المطلوبة تم وضع الصيغ في جدول مستقل لتتمكن من مقارنة النتائج صيغ الأعمدة G + H =LET(extracted_text, IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2), NUMBERVALUE(IF(ISNUMBER(FIND(" ", extracted_text)), TRIM(LEFT(extracted_text, FIND(" ", extracted_text) - 1)), extracted_text))) أو =NUMBERVALUE(IF(ISNUMBER(FIND(" ", IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2))), TRIM(LEFT(IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2), FIND(" ", IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2)) - 1)), IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2)))) صيغ الأعمدة I + J =(IFERROR(VALUE("0 "&MID(F2,FIND(" ",F2)+1,LEN(F2)-FIND(" ",F2))), 0)) + (IFERROR(VALUE("0 "& IF(ISNUMBER(FIND(" ",G2)),TRIM(RIGHT(G2,LEN(G2)-FIND(" ",G2))), 0) ), 0)) بالتوفيق......... Sum Architect Units Feet-Inches V3.xlsx

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

طبعا مما لاشك فيه لابد للطالب من الاستئذان توقيرا واجلا للمعلم القدير الجليل حاسس انى اتدبست - او غلطت فى شئ - أو يتم اختبارى وأنا أقلق من هذه الموافق جدا ولكن سوف ادلى بدلوي فإن اخطأت فهذا مني ومن سوء فهمي وتقديري أنا و وقتها تصحون لي خطئي وجزاكم الله عني كل خير وإن أصبت فلقد تعلمت على ايديكم فأنتم أحد الأساتذة العظماء الذين أدين لهم بالفضل بعد رب العزة سبحانه وتعالي سؤالك جدا ممتاز يا أستاذي ويفتح مجالا لفهم أعمق لدالتي Nz وTrim خاصة في سياق التحقق من الحقول الفارغة دعني أوضح حسب فهمى المتواضح الفائدة من استخدام هاتين الدالتين ومتى تكونان ضرورييتان و ما الفرق بين استخدامهما أو عدمهما مع مثال أولا شرح الدالتين: 1- دالة Nz : Nz(Value, ValueIfNull) تستخدم لتحويل قيمة Null إلى قيمة أخرى محددة (مثل "" أو 0 حسب رغبة مطور النظم ) مفيدة جدا عندما تتعامل مع حقل قد يحتوي على Null لأن أي عملية مقارنة مع Null (مثل Null = "") ترجع Null وليس True أو False 2- دالة Trim : Trim(Value) تزيل المسافات البيضاء (Whitespace) من بداية و نهاية السلسلة النصية مثل " abs " أو " abs" أو "abs " تصبح "abc" لا تتعامل مع Null فإذا كانت القيمة هى Null فإن Trim(Null) يظل Null الهدف: تريد التحقق مما إذا كان الحقل (Me.yyy) "فارغا" أم لا "فارغ" قد يعني: Null (لا قيمة على الإطلاق) "" (سلسلة فارغة). " " أو " " (مسافات فقط) ** إذا كان الحقل فارغا بأي من هذه الحالات يتحقق الشرط و إذا كان يحتوي على قيمة فعلية (مثل "abc") لا يتحقق الشرط. سؤال حضرتك : هل استخدام Nz و Trim يضيف ميزة إضافية في هذا السياق أم أن التحقق الأساسي بـ IsNull و = "" كاف؟ 1- بدون Nz و Trim: If Me.xxx <> 0 And (IsNull(Me.yyy) Or Me.yyy = "") Then ' الشرط تحقق Else End If يتحقق الشرط إذا: Me.yyy هو Null Me.yyy هو "" (سلسلة فارغة) لا يتحقق الشرط إذا: Me.yyy يحتوي على مسافات فقط (مثل " " أو " ")، لأن " " <> "" Me.yyy يحتوي على نص (مثل "abc")، وهذا متوقع 2- مع Nz و Trim: If Me.xxx <> 0 And (IsNull(Me.yyy) Or Trim(Nz(Me.yyy, "")) = "") Then ' الشرط تحقق Else End If يتحقق الشرط إذا: Me.yyy هو Null (لأن Nz يحوله إلى "" و Trim("") = "") Me.yyy هو "" (لأن Trim("") = "") Me.yyy هو " " أو " " (لأن Trim(" ") = "") لا يتحقق الشرط إذا: Me.yyy يحتوي على نص فعلي (مثل "abc")، لأن Trim("abc") <> "" الميزة الإضافية لـ Nz و Trim: Nz: يضمن التعامل مع Null بطريقة آمنة مما يمنع أي أخطاء غير متوقعة إذا حاولت مقارنة Null مباشرة في الكود بدون Nz الشرط IsNull(Me.yyy) كاف لكن استخدام Nz يجعل الكود أكثر مرونة إذا أردت لاحقا إجراء عمليات إضافية على القيمة Trim: يضيف القدرة على اعتبار المسافات البيضاء (Whitespace) كقيمة "فارغة" بدون Trim إذا كان Me.yyy = " " »--»» فإن الشرط لن يتحقق لأن " " <> "" الفرق الأساسي: بدون Trim و Nz: لا يعتبر المسافات فقط (" ") فارغة مع Trim و Nz: يعتبر المسافات فقط فارغة بالإضافة إلى Null و "" الأمثلة العملبة : 1- الكود بدون Nz و Trim Me.xxx = 5 , Me.yyy = Null → "الشرط تحقق" Me.xxx = 5 , Me.yyy = "" → "الشرط تحقق" Me.xxx = 5 , Me.yyy = " " → "الشرط لم يتحقق" (لأن " " <> "") "Me.xxx = 5 , Me.yyy = "abc → "الشرط لم يتحقق" 2- الكود مع Nz و Trim Me.xxx = 5 , Me.yyy = Null → "الشرط تحقق" Me.xxx = 5 , Me.yyy = "" → "الشرط تحقق" Me.xxx = 5 , Me.yyy = " " → "الشرط تحقق" (لأن Trim(" ") = "") "Me.xxx = 5 , Me.yyy = "abc → "الشرط لم يتحقق" الخلاصة: إذا كان مطور النظم لا يهتم بالمسافات (مثل " " ) ويتعتبرها قيمة غير فارغة فالكود الأبسط بدون Nz و Trim كاف إذا كان مطور النظم يريد أن تعتبر المسافات فارغة (مثل " " ) فاستخدام Trim و Nz يعطي ميزة إضافية إذا نستخلص مما سبق أن Trim و Nz يجعلان الكود أكثر شمولية للتعامل مع جميع حالات "الفراغ" ( Null , سلسلة فارغة , مسافات فقط ) مما يجعله أكثر مرونة إذا كانت البيانات غير متسقة أو تحتوي على إدخالات غير متوقعة مثل المسافات

السلام عليكم ورحمة الله وبركاته أشارك معكم اليوم وحدة نمطية متقدمة باسم basShellExecutor تهدف إلى توفير حلول مرنة وفعالة لتنفيذ الأوامر والملفات في بيئة Windows مع تحكم دقيق بالعمليات تم تصميم هذه الوحدة لتلبية احتياجات المطورين المختلفة والمتنوعة وتعرف او شائعه لدى المطورين باسم : ShellWait ولكن تم اعادة هيكلة وتطوير الوظائف بشكل احترافى لاضفاء أكبر قدر ممكن من الفاعليه والمرونة والكفائه وتعدد الاستخدمات ودعم تنوع الخيارات الممكنه بقدر الإمكان مميزات الكود المرونة: يدعم تنفيذ الأوامر بثلاث طرق (انتظار غير محدود , مهلة زمنية محددة , تنفيذ بسيط) مما يجعله متعدد الاستخدامات الاستجابة: يستخدم " DoEvents " لضمان استجابة واجهة المستخدم أثناء الانتظار مما يمنع تجمد التطبيق التحكم الدقيق: يتيح إنهاء الحلقات يدويا عبر متغير عام (g_TerminateLoops) ويمنع التداخل بين الاستدعاءات باستخدام (m_IsExecuting) التوافق: توافق تعريفات API مع أنظمة 32 بت و64 بت معالجة الأخطاء: يوفر معالجة أخطاء قوية مع رسائل واضحة لتسهيل التصحيح التنظيم: مقسم إلى أقسام واضحة (ثوابت , تعريفات , دوال) مع تعليقات عربية شاملة لتسهيل الصيانة والفهم وظيفة الكود تتيح وحدة basShellExecutor تشغيل الأوامر والملفات بثلاث طرق مختلفة مع القدرة على التحكم في وقت التنفيذ و معالجة الأحداث والتقاط النتائج الدوال الرئيسية هي: ExecuteAndWait: الغرض: تنفيذ أمر أو تشغيل ملف والانتظار حتى اكتماله مع استجابة مستمرة لواجهة المستخدم الاستخدام: مثالي للعمليات التي تحتاج إلى إكمال كامل قبل المتابعة (مثل فتح برنامج وانتظار إغلاقه) ExecuteWithTimeout: الغرض: تنفيذ أمر أو تشغيل ملف مع مهلة زمنية مع إمكانية إنهاء العملية إذا تجاوزت الحد الاستخدام: ممناسب للعمليات ذات الوقت المحدود أو التي قد تتوقف (مثل محاولة استخدام أدوات خارجية) ExecuteWScript: الغرض: تنفيذ أمر بسيط باستخدام " WScript.Shell " مع خيار الانتظار الاستخدام: مفيد للمهام السريعة دون تعقيد على سبيل المثال (مثل تشغيل أوامر CMD) ExecuteWScriptCapture (اختياري): الغرض: تنفيذ أمر والتقاط ناتجه النصي للاستخدام البرمجي الاستخدام: مثالي لتحليل نتائج الأوامر (مثل قوائم الملفات من " dir " ) اسم الوحدة النمطية العامة : basShellExecutor الكود : ' يضمن مقارنة النصوص بناءً على إعدادات قاعدة البيانات (مثل ترتيب الحروف واللغة) Option Compare Database ' يجبر على تعريف المتغيرات صراحة قبل استخدامها، مما يمنع الأخطاء الناتجة عن الأسماء الخاطئة Option Explicit '======================================================================================================================= '------ الثوابت Public Const PROCESS_TIMEOUT_INFINITE As Long = &HFFFFFFFF Public Const PROCESS_STILL_ACTIVE As Long = &H103 Public Const PROCESS_TERMINATED As Long = vbObjectError Or &HDEAD Public Const MAX_PATH_LENGTH As Long = 260 Public Const QS_ALL_INPUT As Long = &H4FF Private Const ERR_NO_COMMAND As Long = vbObjectError Or 1001 Private Const ERR_EXECUTING As Long = vbObjectError Or 1002 Private Const ERR_EXECUTION_FAILED As Long = vbObjectError Or 1003 Private Const ERR_TERMINATION_FAILED As Long = vbObjectError Or 1004 Private Const SHELL_MASK_NOCLOSEPROCESS As Long = &H40 Private Const SHELL_MASK_DOENVSUBST As Long = &H200 Private Const SHELL_MASK_SUPPRESS_ERRORS As Long = &H400 Private Const PROCESS_QUERY_INFO As Long = &H400 Private Const PROCESS_SYNCHRONIZE As Long = &H100000 Private Const PROCESS_TERMINATE As Long = &H1 Private Const ERROR_ACCESS_DENIED As Long = 5 '======================================================================================================================= '------ التعدادات Public Enum ShellWindowStyle WindowHidden = 0 WindowNormal = 1 WindowMinimized = 2 WindowMaximized = 3 WindowNoActivate = 4 End Enum '======================================================================================================================= '------ الأنواع المخصصة #If VBA7 Then Private Type ShellExecuteParams Size As Long Mask As Long ParentWindowHandle As LongPtr Verb As String filePath As String Arguments As String WorkingDirectory As String ShowCommand As Long InstanceHandle As LongPtr ItemListPointer As LongPtr ClassName As String ClassKeyHandle As LongPtr HotKey As Long IconHandle As LongPtr ProcessHandle As LongPtr End Type #Else Private Type ShellExecuteParams Size As Long Mask As Long ParentWindowHandle As Long Verb As String filePath As String Arguments As String WorkingDirectory As String ShowCommand As Long InstanceHandle As Long ItemListPointer As Long ClassName As String ClassKeyHandle As Long HotKey As Long IconHandle As Long ProcessHandle As Long End Type #End If '======================================================================================================================= '------ تعريفات API #If VBA7 Then Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPtr ' فتح مقبض العملية Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Long ' إغلاق مقبض العملية Private Declare PtrSafe Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As LongPtr, Optional ByVal lpDst As LongPtr, Optional ByVal nSize As Long) As Long ' توسيع متغيرات البيئة Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByRef lpExitCode As Long) As Long ' جلب رمز الخروج للعملية Private Declare PtrSafe Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As LongPtr, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long ' انتظار العمليات مع معالجة الأحداث Private Declare PtrSafe Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr, Optional ByVal Length As Long) As Long ' إعادة تخصيص حجم السلسلة Private Declare PtrSafe Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As LongPtr, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As LongPtr) As LongPtr ' إنشاء مؤقت قابل للانتظار Private Declare PtrSafe Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As LongPtr) As Long ' جلب معرف العملية Private Declare PtrSafe Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As LongPtr, ByVal lpszSrc As LongPtr) As Long ' تبسيط المسار Private Declare PtrSafe Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As LongPtr ' استخراج المعاملات من المسار Private Declare PtrSafe Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As LongPtr, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As LongPtr, Optional ByVal lpArgToCompletionRoutine As LongPtr, Optional ByVal fResume As Long) As Long ' ضبط المؤقت Private Declare PtrSafe Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As LongPtr) As Long ' تنفيذ أمر عبر Shell Private Declare PtrSafe Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long ' إعادة تخصيص السلسلة Private Declare PtrSafe Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) ' إزالة المعاملات من المسار Private Declare PtrSafe Function TerminateProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByVal uExitCode As Long) As Long ' إنهاء العملية قسريًا Private Declare PtrSafe Function GetTickCount Lib "kernel32.dll" () As Long ' لقياس الوقت المنقضي #Else Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long ' فتح مقبض العملية Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long ' إغلاق مقبض العملية Private Declare Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As Long, Optional ByVal lpDst As Long, Optional ByVal nSize As Long) As Long ' توسيع متغيرات البيئة Private Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCode As Long) As Long ' جلب رمز الخروج للعملية Private Declare Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long ' انتظار العمليات مع معالجة الأحداث Private Declare Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As Long ' إعادة تخصيص حجم السلسلة Private Declare Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As Long, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As Long) As Long ' إنشاء مؤقت قابل للانتظار Private Declare Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As Long) As Long ' جلب معرف العملية Private Declare Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As Long, ByVal lpszSrc As Long) As Long ' تبسيط المسار Private Declare Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long ' استخراج المعاملات من المسار Private Declare Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As Long, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As Long, Optional ByVal lpArgToCompletionRoutine As Long, Optional ByVal fResume As Long) As Long ' ضبط المؤقت Private Declare Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As Long) As Long ' تنفيذ أمر عبر Shell Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long ' إعادة تخصيص السلسلة Private Declare Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) ' إزالة المعاملات من المسار Private Declare Function TerminateProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long ' إنهاء العملية قسريًا Private Declare Function GetTickCount Lib "kernel32.dll" () As Long ' لقياس الوقت المنقضي #End If '======================================================================================================================= '------ المتغيرات العامة و الخاصة Public g_TerminateLoops As Boolean ' متغير للتحكم في إنهاء الحلقات يدويًا Private m_IsExecuting As Boolean ' علامة لمنع التداخل أثناء التنفيذ '======================================================================================================================= '------------------------------------------- الدوال العامة ' تشغيل أمر والانتظار حتى ينتهي مع استجابة الواجهة Public Function ExecuteAndWait(ByVal CommandLine As String, _ Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, _ Optional ByVal RunAsAdmin As Boolean = False, _ Optional ByVal MaxWaitMs As Long = PROCESS_TIMEOUT_INFINITE) As Long #If VBA7 Then Dim ShellParams As ShellExecuteParams Dim ProcessHandle As LongPtr #Else Dim ShellParams As ShellExecuteParams Dim ProcessHandle As Long #End If Dim ExpandedPath As String Dim Executable As String Dim Arguments As String Dim startTime As Long Dim ExitCode As Long Dim Result As Long If m_IsExecuting Then Err.Raise ERR_EXECUTING, "ExecuteAndWait", "عملية أخرى قيد التنفيذ" End If m_IsExecuting = True On Error GoTo Cleanup ' توسيع متغيرات البيئة ExpandedPath = ExpandEnvVars(CommandLine) ' فصل المسار التنفيذي عن المعاملات يدويًا If Left(ExpandedPath, 1) = """" Then Executable = Mid(ExpandedPath, 2, InStr(2, ExpandedPath, """") - 2) Arguments = Trim(Mid(ExpandedPath, InStr(2, ExpandedPath, """") + 2)) Else Dim Parts() As String Parts = Split(ExpandedPath, " ", 2) Executable = Parts(0) If UBound(Parts) > 0 Then Arguments = Parts(1) Else Arguments = "" End If With ShellParams .Size = LenB(ShellParams) .Mask = SHELL_MASK_NOCLOSEPROCESS Or SHELL_MASK_DOENVSUBST Or SHELL_MASK_SUPPRESS_ERRORS .ShowCommand = WindowStyle .filePath = CanonicalizePath(Executable) ' المسار التنفيذي فقط .Arguments = Arguments ' المعاملات كما هي If RunAsAdmin Then .Verb = "runas" If ShellExecuteExW(VarPtr(ShellParams)) = 0 Then Err.Raise ERR_EXECUTION_FAILED, "ExecuteAndWait", "فشل في تنفيذ الأمر: " & CommandLine End If ProcessHandle = .ProcessHandle End With startTime = GetTickCount Do Result = MsgWaitForMultipleObjects(1, ProcessHandle, False, 100, QS_ALL_INPUT) DoEvents If GetExitCodeProcess(ProcessHandle, ExitCode) Then If ExitCode <> PROCESS_STILL_ACTIVE Then Exit Do End If If MaxWaitMs <> PROCESS_TIMEOUT_INFINITE Then If (GetTickCount - startTime) > MaxWaitMs Then Debug.Print "تجاوز الحد الأقصى للانتظار: " & MaxWaitMs & " ميلي ثانية" Exit Do End If End If Loop ExecuteAndWait = ExitCode Cleanup: If ProcessHandle <> 0 Then CloseHandle ProcessHandle m_IsExecuting = False If Err.Number <> 0 Then Err.Raise Err.Number, "ExecuteAndWait", Err.Description End Function ' دالة لتنفيذ أمر مع مهلة زمنية اختيارية وخيار التشغيل كمسؤول Public Function ExecuteWithTimeout(Command As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, Optional ByVal TimeoutMs As Long, Optional ByVal RunAsAdmin As Boolean = False, Optional RetryCount As Long = 0) As Long #If VBA7 Then Dim ShellParams As ShellExecuteParams Dim ProcessHandle As LongPtr #Else Dim ShellParams As ShellExecuteParams Dim ProcessHandle As Long #End If Dim ExpandedPath As String Dim Executable As String Dim Arguments As String Dim startTime As Long Dim ExitCode As Long Dim Result As Long Dim RetryIndex As Long If m_IsExecuting Then Err.Raise ERR_EXECUTING, "ExecuteWithTimeout", "عملية أخرى قيد التنفيذ" End If m_IsExecuting = True On Error GoTo Cleanup ExpandedPath = ExpandEnvVars(Command) ' فصل المسار التنفيذي عن المعاملات يدويًا If Left(ExpandedPath, 1) = """" Then Executable = Mid(ExpandedPath, 2, InStr(2, ExpandedPath, """") - 2) Arguments = Trim(Mid(ExpandedPath, InStr(2, ExpandedPath, """") + 2)) Else Dim Parts() As String Parts = Split(ExpandedPath, " ", 2) Executable = Parts(0) If UBound(Parts) > 0 Then Arguments = Parts(1) Else Arguments = "" End If For RetryIndex = 0 To RetryCount With ShellParams .Size = LenB(ShellParams) .Mask = SHELL_MASK_NOCLOSEPROCESS Or SHELL_MASK_DOENVSUBST Or SHELL_MASK_SUPPRESS_ERRORS .ShowCommand = WindowStyle .filePath = CanonicalizePath(Executable) ' المسار التنفيذي فقط .Arguments = Arguments ' المعاملات كما هي If RunAsAdmin Then .Verb = "runas" If ShellExecuteExW(VarPtr(ShellParams)) = 0 Then If RetryIndex = RetryCount Then Err.Raise ERR_EXECUTION_FAILED, "ExecuteWithTimeout", "فشل في تنفيذ الأمر بعد " & RetryCount + 1 & " محاولات: " & Command End If Else ProcessHandle = .ProcessHandle Exit For End If End With Next RetryIndex startTime = GetTickCount Do Result = MsgWaitForMultipleObjects(1, ProcessHandle, False, 100, QS_ALL_INPUT) DoEvents If GetExitCodeProcess(ProcessHandle, ExitCode) Then If ExitCode <> PROCESS_STILL_ACTIVE Then Exit Do End If If TimeoutMs > 0 Then If (GetTickCount - startTime) > TimeoutMs Then If TerminateProcess(ProcessHandle, PROCESS_TERMINATED) = 0 Then Debug.Print "فشل في إنهاء العملية بعد تجاوز المهلة" End If ExitCode = PROCESS_TERMINATED Exit Do End If End If If g_TerminateLoops Then Exit Do Loop ExecuteWithTimeout = ExitCode Cleanup: If ProcessHandle <> 0 Then CloseHandle ProcessHandle m_IsExecuting = False If Err.Number <> 0 Then Err.Raise Err.Number, "ExecuteWithTimeout", Err.Description End Function ' دالة لتشغيل أمر باستخدام WScript.Shell مع خيار الانتظار Public Function ExecuteWScript(ByVal CommandLine As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, Optional ByVal WaitForCompletion As Boolean = False) As Long Dim WScriptShell As Object On Error GoTo ErrorHandler Set WScriptShell = CreateObject("WScript.Shell") ExecuteWScript = WScriptShell.Run(CommandLine, WindowStyle, WaitForCompletion) Exit Function ErrorHandler: Debug.Print "خطأ في تشغيل الأمر عبر WScript: " & Err.Description Err.Raise Err.Number, "ExecuteWScript", "خطأ في تشغيل الأمر عبر WScript: " & Err.Description End Function ' دالة محسنة لتشغيل أمر باستخدام WScript.Shell والتقاط الناتج Public Function ExecuteWScriptCapture(ByVal CommandLine As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal) As String Dim WScriptShell As Object Dim ShellExec As Object Dim Output As String On Error GoTo ErrorHandler Set WScriptShell = CreateObject("WScript.Shell") Set ShellExec = WScriptShell.Exec(CommandLine) Do While ShellExec.Status = 0 DoEvents Loop Output = ShellExec.StdOut.ReadAll ExecuteWScriptCapture = Output Exit Function ErrorHandler: Debug.Print "خطأ في تشغيل الأمر عبر WScript: " & Err.Description ExecuteWScriptCapture = "" Err.Raise Err.Number, "ExecuteWScriptCapture", "خطأ في تشغيل الأمر عبر WScript: " & Err.Description End Function '======================================================================================================================= '------ الدوال المساعدة ' دالة لتوسيع متغيرات البيئة في سلسلة (مثل %windir%) Private Function ExpandEnvVars(ByVal Path As String) As String Dim Buffer As String Dim Length As Long If InStr(Path, "%") Then Length = ExpandEnvironmentStringsW(StrPtr(Path), 0, 0) If Length > 0 Then Buffer = String$(Length - 1, vbNullChar) If ExpandEnvironmentStringsW(StrPtr(Path), StrPtr(Buffer), Length) Then ExpandEnvVars = Left$(Buffer, Length - 1) Else Debug.Print "فشل توسيع متغيرات البيئة، يتم إرجاع المسار الأصلي: " & Path ExpandEnvVars = Path End If Else ExpandEnvVars = Path End If Else ExpandEnvVars = Path End If End Function ' دالة لتبسيط المسار (مثل حل النقاط . و ..) Private Function CanonicalizePath(ByVal Path As String) As String Dim TempPath As String If InStr(Path, "\.") Or InStr(Path, ".\") Then If Len(Path) < MAX_PATH_LENGTH Then TempPath = String$(MAX_PATH_LENGTH - 1, vbNullChar) If PathCanonicalizeW(StrPtr(TempPath), StrPtr(Path)) Then CanonicalizePath = Left$(TempPath, InStr(TempPath, vbNullChar) - 1) Else Debug.Print "فشل تبسيط المسار، يتم إرجاع المسار الأصلي: " & Path CanonicalizePath = Path End If Else CanonicalizePath = Path End If Else CanonicalizePath = Path End If End Function ' دالة لاستخراج المعاملات من المسار Private Function ExtractArguments(ByRef Path As String) As String SysReAllocString VarPtr(ExtractArguments), PathGetArgsW(StrPtr(Path)) If LenB(ExtractArguments) Then PathRemoveArgsW StrPtr(Path) If InStr(ExtractArguments, """") Then ExtractArguments = Replace(ExtractArguments, """", """""") End If End Function ' دالة مساعدة لاستخراج اسم العملية من الأمر Private Function ExtractProcessName(ByVal CommandLine As String) As String Dim Parts() As String Dim FirstPart As String If Left(CommandLine, 1) = """" Then FirstPart = Mid(CommandLine, 2, InStr(2, CommandLine, """") - 2) Else Parts = Split(CommandLine, " ") FirstPart = Parts(0) End If ExtractProcessName = Mid(FirstPart, InStrRev(FirstPart, "\") + 1) End Function ' دالة لإنهاء عملية باستخدام WMI بناءً على اسم العملية Public Function KillProcess(sProcessName As String, Optional sHost As String = ".") As Boolean On Error GoTo Error_Handler Dim oWMI As Object Dim sWMIQuery As String Dim oCols As Object Dim oCol As Object Set oWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & sHost & "\root\cimv2") sWMIQuery = "SELECT Name FROM Win32_Process" Set oCols = oWMI.ExecQuery(sWMIQuery) For Each oCol In oCols If LCase(sProcessName) = LCase(oCol.Name) Then oCol.Terminate End If Next oCol KillProcess = True Error_Handler_Exit: On Error Resume Next Set oCol = Nothing Set oCols = Nothing Set oWMI = Nothing Exit Function Error_Handler: Debug.Print "خطأ في KillProcess: " & Err.Description & " - رقم الخطأ: " & Err.Number KillProcess = False Resume Error_Handler_Exit End Function وأخيــــرا الامثلة : '======================================================================================================================= '------ أمثلة الاستدعاء ' مثال لاستدعاء ExecuteAndWait ' يفتح Notepad وينتظر إغلاقه Sub TestExecuteAndWait() Dim ExitCode As Long On Error Resume Next ExitCode = ExecuteAndWait("notepad.exe C:\test.txt", WindowNormal) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "رمز الخروج: " & ExitCode Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout ' يفتح الحاسبة وينتظر 5 ثوانٍ كحد أقصى Sub TestExecuteWithTimeout() Dim ProcessId As Long On Error Resume Next ProcessId = ExecuteWithTimeout("paint.exe", WindowMaximized, 5000) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScript ' يشغل أمر dir في CMD وينتظر النتيجة Sub TestExecuteWScript() Dim Result As Long On Error Resume Next Result = ExecuteWScript("cmd.exe /c dir", WindowNormal, True) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "النتيجة: " & Result Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScript مع إبقاء النافذة مفتوحة Sub TestExecuteWScript_KeepOpen() Dim Result As Long ' استخدام /k بدلاً من /c لإبقاء نافذة CMD مفتوحة بعد تنفيذ الأمر On Error Resume Next Result = ExecuteWScript("cmd.exe /k dir", WindowNormal, False) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "النتيجة: " & Result Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout لتشغيل CMD Sub TestExecuteWithTimeoutCMD() Dim ProcessId As Long ' تشغيل CMD مع أمر dir وانتظار 5 ثوانٍ كحد أقصى On Error Resume Next ProcessId = ExecuteWithTimeout("cmd.exe /k dir", WindowNormal, 5000) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout مع RunAsAdmin وإعادة المحاولة Sub TestExecuteWithTimeoutAdmin() Dim ProcessId As Long ' تشغيل CMD كمسؤول وانتظار 5 ثوانٍ كحد أقصى مع محاولتين On Error Resume Next ProcessId = ExecuteWithTimeout("cmd.exe /k dir", WindowNormal, 5000, True, 2) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScriptCapture Sub TestExecuteWScriptCapture() Dim CommandOutput As String ' تنفيذ أمر dir والتقاط الناتج On Error Resume Next CommandOutput = ExecuteWScriptCapture("cmd.exe /c dir") Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "ناتج الأمر:" & vbCrLf & CommandOutput Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub تمنياتى القلبيــــه بأكبر قدر ممكن من تحصيل المتعة والاستفاده

السلام عليكم ورحمة الله تعالى وبركاته اليكم هديه اخرى ولكن الحق أحق أن يتبع كل الشكر و التقدير لاستاذى الجليل ومعلمى القدير و اخى الحبيب الاستاذ @Foksh على موضوع : ⭐ هدية ~ تغيير لغة النظام في Unicode⭐ قمت بعمل تحديثات جذرية فى هيكل وبناء الكود المميزات : عدم الاعتماد على وسيط بانشاء ملف فى مسار محدد لتمرير اومر الاعدادات ثم حذفه بعد تمرريرها وتطبيقها اضافة نموذج جديد للتحكم فى اختيار وتنسيق الوقت والتاريخ بشكل فورى امكانيه اضافة تخطيط لوحات مفاتيح للغات مختلفة حسب الحاجة والرغبه امكانية حذف تخطيط لغة/لغات لوحات مفاتيح من مربع القيم باختيار مفرد او متعدد لاكثر من لغة التخلص من تخطيطات لوحات المفاتيح المزعجة وحذفها بسهوله و التى قد تصادف العديد عند استخدام قواعد بيانات تعديل التنسيق للوقت والتاريخ او اضافة تخطيط لغة مفاتيح او حذفها لا يتطلب اعادة التشغيل مطلقا امكانية نقل النماذج لاى قاعدة للعمل فورا بدون اى تعديلات تذكر واخيـــــــــــــر المرفق اتمنى لكم تجربة ممتعة LanguageCheck V3.0.1.accdb

وعليكم السلام ورحمة الله تعالى وبركاته يجب أولا التأكد من عدم تعطيل وحدات الماكرو بسبب أمان الملفات أغلق الملف ثم انقر بزر الماوس الأيمن على خصائص <------ إلغاء الحظر (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

السلام عليكم ورحمه الله وبركاته وبها نبدأ 1- قم بوضع هذا الكود في موديل جديد 2- قم بحفظ الملف بصيغه تقبل الماكرو وليكن XLSB 3- ثم شغل الكود Sub Tarhil() Dim WS As Worksheet, SH As Worksheet, AR1, AR2, I As Long, J As Long, LR1 As Long, LR2 As Long Set WS = ThisWorkbook.Sheets("فواتير العملاء") Set SH = ThisWorkbook.Sheets("فاتورة المبيعات") AR1 = Array("C3", "C4", "E4", "C5", "C6", "E3", "H3", "J4", "J6") AR2 = Array("B", "C", "D", "E", "F", "G", "H", "I", "J") LR1 = SH.ListObjects("الجدول4").Range.Columns(2).Cells.Find("*", SearchDirection:=xlPrevious).Row LR2 = WS.ListObjects("الجدول2").Range.Columns(1).Cells.Find("*", SearchDirection:=xlPrevious).Row + 1 For I = 8 To LR1 For J = 1 To 9 WS.Cells(LR2, J).Value = SH.Range(AR1(J - 1)).Value Next J For J = 10 To 18 WS.Cells(LR2, J).Value = SH.Cells(I, AR2(J - 10)) Next J LR2 = LR2 + 1 Next I End Sub

السلام عليكم و رحمة الله استخدم هذا الكود Sub ReArrange() Dim Arr, Rtb, Tmp Dim WF As Object Dim x As Integer, i As Long, p As Long Set WF = WorksheetFunction Arr = Range("B2:C8").Value Rtb = Array("السابعة", "السادسة", "الخامسة", _ "الرابعة", "الثالثة", "الثانية", "الاولى") ReDim Tmp(1 To UBound(Arr, 1), 2) For i = LBound(Rtb) To UBound(Rtb) Tmp(i + 1, 1) = Replace(Arr(i + 1, 2), Arr(i + 1, 2), Rtb(i)) Tmp(i + 1, 0) = WF.Index(Range("B2:C8"), WF.Match(Rtb(i), _ Range("C2:C8"), 0), 1) Next Range("B2").Resize(UBound(Tmp, 1), 2).Value = Tmp End Sub

السلام عليكم الموضوع تم عمله سابقا و لطلبه مرة اخري وصعوبة ايجاده تم عمله بموضوع منفصل لنتمكن من تطويره حسب ما يطلب و لايجاده بسهوله الملف يقوم بعمل الاتي حفظ الفاتورة فقط برقمها في فولدر ملف الاكسل الاساسي تغير سيريال الفاتوره مسح الفاتوره الاساسية لتجهيزها لفاتورة جديدة حفظ الملف الاساسي تحياتي Save invoice.rar

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

السلام عليكم اخواني اتت الفكرة بناء علي طلب احد الاخوة وتخطت ذلك لجعلها تقويم لاي سنه و اظهار صورة لكل شهر فكرة البرنامج في الخلية B2 اكتب السنة التي تريد عمل تقويم لها في الخلية A2 اختر الشهر الذي تريد يوجد فولدر مرفق اسمه Pic موضوع به 12 صورة بعدد اشهر السنة و كل صورة باسم الشهر الخاص بها فمثلا يناير صورتة اسمها 1 و هكذا و لابد ان يكون نسق الصورة jpg و عندما تريد تغير الصوره فقط ضعها في هذا الفولدر و سمها باسم الشهر كما سبق التوضيح طبعا بعد الغاء اي صوره تحمل نفس الاسم ارجو التجربة و اخباري النتيجة تحياتي تقويم.rar

السلام عليكم عذرا اخواني فقد لاحظت ان زر اخفاء لم ترفق اكواده لذا تم رقع الملف مرة اخري بعد التعديل تحياتي Dinamic_Lable_final.rar

السلام عليكم و رحمة الله وبركاته ‏‏‏‏‏‏‏‏‏الاثنين‏، 24‏/12‏/1429هـ. الموافق ‏22‏/12‏/08م اخي الفاضل aah_aah2008 استاذي الفاضل خبور الف تحية وتقدير البرنامج جدا رائع و ممتازة ويكفية شرفا انة صادر من قبل اثنين من الأساتذة الكبار في المنتدى بعد استخدامي للملف وددت ان اطلعكم على اضافة بسيطة الى الملف لكي يكون اكثر فائدة لقد تم عمل تعديل على معادلات المجموع بحيث تقوم بحسابات اخرى غير الجمع يمكن للمستخدم تحديدها حسب رغبتة بتبديل كلمة المجموع الى مايختارة من القائمة و لكما كل التقدير و الإحترام Dinamic_Lable_ay.rar

السلام عليكم تواصلاً للفكرة الجميلة للاخ عادل تفضلوا المرفق تحياتي لجميع المشاركين حفظهم الله ______________.rar

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