mahmoud nasr alhasany

لم اجد المشاركة للعمل فى اضافات فاتورة الشراء او البيع من الاخوة الزملاء

اشكر اخى عبدالله بشير عبدالله على هذه الملاحظة وتم التعديل عليها دليل ميزات للمستخدمين والإدارة: وثيقة التحديثات الأمنية ومميزات واجهة تسجيل الدخول المحدثة تم تطوير وتحديث واجهة تسجيل الدخول البرمجية (Login Form) وتزويدها بحزمة من المزايا الذكية التي تضمن أعلى مستويات الأمان، الخصوصية، وسلاسة تجربة المستخدم (UI/UX). تلخص هذه الوثيقة أهم الإضافات البرمجية وفوائدها التقنية والتشغيلية: 1. الفحص الذكي للاتصال بالإنترنت (Active Connectivity Verification) الوصف الفني: يعتمد النظام على استدعاء دوال ويندوز السيادية (WinINet API) للتحقق الفعلي واللحظي من وجود اتصال إنترنت نشط بجهاز المستخدم قبل البدء في معالجة طلب استرجاع البيانات. فوائد العمل: منع الأخطاء البرمجية: يمنع تجمد أو توقف (Freeze) برنامج إكسيل عند محاولة فتح روابط خارجية في غياب الشبكة. توجيه ذكي للمستخدم: يظهر رسالة تنبيهية فورية وواضحة للمستخدم تفيد بأن "الإنترنت غير فعال" مع إيقاف الإجراء فوراً لتوفير الوقت والجهد. 2. التشفير والتخفي البصري للبيانات (Advanced Visual Masking) الوصف الفني: استخدام خاصية الحجب التلقائي PasswordChar لحقول البريد الإلكتروني ورقم الواتساب بمجرد استدعائها وعرضها على الشاشة لتظهر على هيئة رموز نجوم (***). فوائد العمل: حماية الخصوصية: يمنع المتطفلين أو المحيطين بالمستخدم من رؤية بيانات الأمان الحساسة المعروضة على الشاشة. كفاءة برمجية: التشفير بصري فقط على الواجهة؛ مما يعني أن النظام يقرأ ويكتب البيانات الحقيقية من وإلى قاعدة البيانات (شيت إكسيل) بسلاسة تامة ودون أي تعارض. 3. حماية البيانات ضد التعديل والتلاعب (Write-Protection & Locking) الوصف الفني: تطبيق خاصية القفل التام Locked = True على حقول الاسترجاع (البريد والواتساب) فور ظهورها على الشاشة. فوائد العمل: سلامة البيانات: منع المستخدم من الكتابة داخل هذه الحقول أو تعديلها أو مسحها بالخطأ، مما يضمن دقة البيانات المسترجعة. وضوح الرؤية: تضمن هذه الخاصية بقاء النصوص واضحة ومقروءة للمستخدم، على عكس خاصية الإلغاء الكامل (Enabled = False) التي تجعل الحقول باهتة وصعبة القراءة. 4. التنسيق البصري والديناميكي للواجهة (Dynamic UI Alignment) الوصف الفني: إعادة برمجة إحداثيات عناصر الشاشة (الخاصية .Top و .Height) لتتفاعل وتتمدد أوتوماتيكياً عند طلب استرجاع الحساب. فوائد العمل: مظهر احترافي ومتناسق: تم ترحيل زر اختيار لغة البرنامج chkLanguage وزر التذكر وزر الدخول إلى الأسفل بدقة متناهية فور تمدد الحقول، مما يمنع تماماً تداخل العناصر بصرياً ويحافظ على جمالية الواجهة. 5. دعم ثنائية اللغة الفورية (Instant Bilingual Support) الوصف الفني: نظام ترجمة مدمج يتفاعل لحظياً مع اختيار المستخدم للغة (العربية أو الإنجليزية). فوائد العمل: مرونة التشغيل: تترجم جميع العناوين، الحقول، الرسائل التنبيهية، وحتى نوافذ التأكيد فوراً بمجرد الضغط على خيار اللغة دون الحاجة لإعادة تشغيل البرنامج أو إغلاقه. 6. تدوين ومراقبة سجلات الدخول (Automated Security Logging) الوصف الفني: تفعيل نظام تدوين خلفي (سري) يقوم بتسجيل كل حركة دخول ناجحة أو خاطئة في شيتات مخصصة (Log_Success و Log_Failed). فوائد العمل: الرقابة والأمن: تتبع تفصيلي لعمليات الدخول يشمل (التاريخ، الوقت، اسم المستخدم، وعدد المحاولات)، مع حظر المنظومة وإغلاق الملف بالكامل تلقائياً عند تجاوز 3 محاولات خاطئة لحماية أرصدة وبيانات المنشأة. ملحوظة تم اضافة تسجيل المستخدمين سواء كان ادارة او موظفين مع تحديد مستوى المشاهدة والصلاحيات والرجاء من يريد المساهمة فى عمل المشروع لوجة الله تعالى يتفضل مشكورا لتعم الفائدة على الجميع هنا تم عمل شاشة دخول و تسجيل مستخدمين و تحويل يبن المخازن و جارى عمل فاتورة شراء TransferSystem 2027 - Copy - Copy.xlsm

السلام عليكم ورحمة الله وبركاتة مرفق لكم لقد صممت برنامج مخازن يحتوى على دخول مستخدمين اجبارى كلمة المستخدم admin كلمة السر 123 اختيارى دخول بريد الكترونى رجاء كتابة البريد ضرورى دخول رقم الهاتف رجاء كتابة رقم الواتس ضرورى ويبدأ من 201 لانة سيربط نسيان كلمة المرور مستقبليا اما بخصوص نسيان كلمة السر فهى جارى العمل عليها لانها تحت التطوير وايضا عند الدخول يعطى شاشة ترحيب جميلة جدا كأنة يقوم بالدخول الى النظام وايضا عند الدخول الى النظام يدخل الى شاشة به محتويات اساسيات تحتوى على 1 - تكويدات ( مخازن وموردين واصناف وعملاء ومندوبين ) 2 - حركة الاصناف 3 - حركة المشتريات والمبيعات والمرتجعات وتسوية مخزون 4 - تقريرات 5 - صلاحيات دخول المستخدمين 6 - عمل نسخة احتياضية بمجرد ان تقوم بتحديد كلا من الخيارات يظهر تلقائى البنود الخاصة بكل خيار تم عمل حركة تحويل بين المخازن مبدئيا ويتم عمل جميع الحركات من شراء وبيع والخ ارجو ان ينال اعجابكم وشكرا لكم TransferSystem 2027.xlsm

انا عايز اربط العميل بالمخزن لو افترضنا ان المخزن ده مندوب سيارة بحيث عند اختيار مخزن سيارة معين يظهر كل العملاء الخاصه به

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

لقد صممت بداية المشروع واضافات التسميات رجاء التكملة مخزن محاسبى - Copy.xlsm

حد الطلب وتاريخ الصلاحية معاً عند فتح الملف أو عند استدعائه يدوياً. ضع هذا الكود في Module عام: Sub CheckReorderLevels() Dim wsSetup As Worksheet: Set wsSetup = Sheets("Setup") Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim lastRowSetup As Long, i As Long Dim currentBal As Double, reorderLevel As Double Dim itemName As String Dim lowStockMsg As String, expiryMsg As String Dim monthsLimit As Integer: monthsLimit = 3 lastRowSetup = wsSetup.Cells(wsSetup.Rows.Count, 2).End(xlUp).Row lowStockMsg = "" expiryMsg = "" ' 1. فحص حد الطلب (بناءً على الأرصدة الحالية) For i = 2 To lastRowSetup itemName = wsSetup.Cells(i, 2).Value ' اسم الصنف من شيت Setup reorderLevel = wsSetup.Cells(i, 4).Value ' حد الطلب من شيت Setup ' حساب الرصيد الإجمالي للصنف من شيت الحركات (الوارد - الصادر) currentBal = Application.WorksheetFunction.SumIf(wsTrans.Range("E:E"), itemName, wsTrans.Range("I:I")) - _ Application.WorksheetFunction.SumIf(wsTrans.Range("D:D"), itemName, wsTrans.Range("I:I")) If currentBal <= reorderLevel Then lowStockMsg = lowStockMsg & "- " & itemName & " (الرصيد: " & currentBal & " / حد الطلب: " & reorderLevel & ")" & vbCrLf End If Next i ' 2. فحص تواريخ الصلاحية (أقل من 3 أشهر) Dim lastRowTrans As Long lastRowTrans = wsTrans.Cells(wsTrans.Rows.Count, 1).End(xlUp).Row For i = 2 To lastRowTrans ' افترضنا أن تاريخ الصلاحية في العمود رقم 10 (J) والكمية في 9 (I) If IsDate(wsTrans.Cells(i, 10).Value) And wsTrans.Cells(i, 9).Value > 0 Then If DateDiff("m", Date, wsTrans.Cells(i, 10).Value) <= monthsLimit And wsTrans.Cells(i, 10).Value >= Date Then expiryMsg = expiryMsg & "- " & wsTrans.Cells(i, 6).Value & " (ينتهي في: " & wsTrans.Cells(i, 10).Value & ")" & vbCrLf End If End If Next i ' --- إظهار التنبيهات للمستخدم --- If lowStockMsg <> "" Then MsgBox "⚠️ أصناف وصلت لحد الطلب:" & vbCrLf & lowStockMsg, vbExclamation, "تنبيه المخزون" End If If expiryMsg <> "" Then MsgBox "📅 أصناف تقترب صلاحيتها من الانتهاء:" & vbCrLf & expiryMsg, vbCritical, "تنبيه الصلاحية" End If End Sub

1. تصميم نموذج الإدخال (UserForm) قم بإنشاء UserForm جديد في محرر VBA (Alt + F11) وقم بتسمية العناصر كالتالي: ComboBox1: لنوع الحركة (إضافة، صرف، تحويل، شراء، بيع). ComboBox2: للمخزن (المصدر/الرئيسي). ComboBox3: للمخزن (الهدف - يظهر فقط في حالة التحويل). ComboBox4: للصنف. ComboBox5: للوحدة. ComboBox6: للحالة (جديد، مستعمل، تالف). TextBox1: للكمية. Listbox1 : عرض البيانات CommandButton1: زر "ترحيل CommandButton2: زر "حفظ Private Sub UserForm_Initialize() Dim wsSetup As Worksheet Set wsSetup = Sheets("Setup") Dim lastRow As Long ' 1. تعبئة أنواع الحركة يدوياً ComboBox1.List = Array("إضافة", "صرف", "تحويل", "شراء", "بيع") ' 2. تعبئة المخازن من شيت Setup (العمود A) lastRow = wsSetup.Cells(wsSetup.Rows.Count, 1).End(xlUp).Row ComboBox2.List = wsSetup.Range("A2:A" & lastRow).Value ' من مخزن ComboBox3.List = wsSetup.Range("A2:A" & lastRow).Value ' إلى مخزن ' 3. تعبئة الأصناف من شيت Setup (العمود B) lastRow = wsSetup.Cells(wsSetup.Rows.Count, 2).End(xlUp).Row ComboBox4.List = wsSetup.Range("B2:B" & lastRow).Value ' 4. تعبئة الوحدات والحالات بنفس الطريقة ComboBox5.List = Array("قطعة", "كيلو", "كرتونة") ComboBox6.List = Array("جديد", "مستعمل", "تالف") ' تحديث ListBox لعرض آخر الحركات UpdateListBox End Sub الحركة". Private Sub ComboBox1_Change() ' إذا كانت الحركة تحويل، أظهر خانة المخزن المحول إليه If ComboBox1.Value = "تحويل" Then ComboBox3.Visible = True Label_ToStore.Visible = True ' افترضنا أنك وضعت عنواناً بجانبه Else ComboBox3.Visible = False Label_ToStore.Visible = False ComboBox3.Value = "" ' مسح القيمة إذا لم تكن تحويلاً End If End Sub Sub UpdateListBox() Dim ws As Worksheet Set ws = Sheets("Transactions") Dim lastRow As Long lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row ' ضبط عدد الأعمدة في ListBox With ListBox1 .ColumnCount = 5 .ColumnWidths = "60;60;80;80;50" ' عرض آخر 5 صفوف فقط (إذا توفرت) If lastRow > 5 Then .List = ws.Range("A" & lastRow - 4 & ":E" & lastRow).Value ElseIf lastRow > 1 Then .List = ws.Range("A2:E" & lastRow).Value End If End With End Sub Private Sub BtnSearch_Click() Dim ws As Worksheet: Set ws = Sheets("Transactions") Dim rowNum As Long Dim searchText As String searchText = TxtSearch.Value ' خانة البحث عن رقم الإذن On Error Resume Next ' البحث عن رقم الإذن في العمود الثاني (رقم الإذن) rowNum = Application.Match(CLng(searchText), ws.Columns(2), 0) On Error GoTo 0 If rowNum > 0 Then ' تعبئة الخانات بالبيانات الموجودة في الشيت ComboBox1.Value = ws.Cells(rowNum, 2).Value ' نوع الحركة ComboBox2.Value = ws.Cells(rowNum, 3).Value ' من مخزن ' ... استكمل لبقية الخانات ... TextBox1.Value = ws.Cells(rowNum, 8).Value ' الكمية ' تخزين رقم الصف في Label مخفي للرجوع إليه عند التعديل LblRowNumber.Caption = rowNum MsgBox "تم جلب البيانات، يمكنك تعديلها الآن", vbInformation Else MsgBox "رقم الإذن غير موجود", vbExclamation End If End Sub Private Sub BtnUpdate_Click() Dim ws As Worksheet: Set ws = Sheets("Transactions") Dim rowNum As Long rowNum = Val(LblRowNumber.Caption) ' استرجاع رقم الصف المخزن If rowNum > 1 Then ws.Cells(rowNum, 2).Value = ComboBox1.Value ws.Cells(rowNum, 3).Value = ComboBox2.Value ws.Cells(rowNum, 5).Value = ComboBox4.Value ws.Cells(rowNum, 8).Value = CDbl(TextBox1.Value) MsgBox "تم تحديث البيانات بنجاح", vbInformation UpdateListBox ' تحديث القائمة لرؤية التعديل End If End Sub Function GetNextSerial() As Long Dim ws As Worksheet: Set ws = Sheets("Transactions") Dim lastRow As Long lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row If lastRow < 2 Then GetNextSerial = 1001 ' يبدأ الترقيم من هذا الرقم Else GetNextSerial = ws.Cells(lastRow, 2).Value + 1 End If End Function Function ConvertToBox(ItemName As String, TotalPieces As Double) As String Dim wsSetup As Worksheet: Set wsSetup = Sheets("Setup") Dim PackSize As Integer Dim Boxes As Integer, Remainder As Integer Dim cell As Range ' البحث عن سعة كرتونة الصنف في شيت Setup Set cell = wsSetup.Range("B:B").Find(ItemName, LookIn:=xlValues, LookAt:=xlWhole) If Not cell Is Nothing Then PackSize = cell.Offset(0, 1).Value ' السعة موجودة في العمود التالي If PackSize > 0 Then Boxes = Int(TotalPieces / PackSize) ' عدد الكراتين الكاملة Remainder = TotalPieces Mod PackSize ' القطع المتبقية ConvertToBox = Boxes & " كرتونة و " & Remainder & " قطعة" Else ConvertToBox = TotalPieces & " قطعة" End If Else ConvertToBox = TotalPieces & " قطعة" End If End Function Private Sub TxtQty_Change() On Error Resume Next If TxtQty.Value <> "" And ComboBox4.Value <> "" Then ' تحديث العنوان بالتحويل التلقائي LblPackingInfo.Caption = ConvertToBox(ComboBox4.Value, CDbl(TxtQty.Value)) Else LblPackingInfo.Caption = "" End If End Sub Sub RefreshInventoryReport() Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim wsInv As Worksheet: Set wsInv = Sheets("Inventory_Summary") Dim lastRow As Long, i As Long ' مسح البيانات القديمة wsInv.Range("A2:E1000").ClearContents ' استخدام Pivot Table خلفي أو مجموع شرطي لجلب الأرصدة ' هنا سنفترض أنك تريد جلب الأصناف الفريدة المتاحة ' كود مبسط لجلب الأرصدة: lastRow = wsTrans.Cells(wsTrans.Rows.Count, 5).End(xlUp).Row ' كود افتراضي لجمع الكميات (يفضل استخدام PivotTable لسرعة أكبر في البيانات الضخمة) ' ولكن هنا سنستخدم الدالة التي برمجناها سابقاً للتحويل ' مثال لتعبئة الصف الأول (كمثال توضيحي): Dim totalQty As Double: totalQty = 150 ' هذا الرقم يأتي من SUMIFS Dim itemName As String: itemName = "صنف A" wsInv.Range("A2").Value = itemName wsInv.Range("D2").Value = totalQty ' استخدام الدالة التي صممناها في الخطوة السابقة wsInv.Range("E2").Value = ConvertToBox(itemName, totalQty) End Sub Private Sub ComboBox4_Change() Dim ws As Worksheet: Set ws = Sheets("Transactions") Dim CurrentStock As Double Dim ItemName As String: ItemName = ComboBox4.Value Dim StoreName As String: StoreName = ComboBox2.Value ' المخزن المختار ' حساب الرصيد الحالي برمجياً باستخدام WorksheetFunction CurrentStock = Application.WorksheetFunction.SumIfs(ws.Range("I:I"), ws.Range("F:F"), ItemName, ws.Range("D:D"), StoreName) - _ Application.WorksheetFunction.SumIfs(ws.Range("I:I"), ws.Range("F:F"), ItemName, ws.Range("C:C"), StoreName) ' عرض النتيجة للمستخدم مع التحويل للكراتين LblCurrentBalance.Caption = "الرصيد المتاح في هذا المخزن: " & ConvertToBox(ItemName, CurrentStock) End Sub Private Sub BtnSave_Click() Dim ws As Worksheet: Set ws = Sheets("Transactions") Dim CurrentStock As Double Dim ItemName As String: ItemName = ComboBox4.Value Dim StoreName As String: StoreName = ComboBox2.Value Dim RequestedQty As Double: RequestedQty = CDbl(TxtQty.Value) ' فحص إذا كانت الحركة (صرف، بيع، أو تحويل صادر) If ComboBox1.Value = "صرف" Or ComboBox1.Value = "بيع" Or ComboBox1.Value = "تحويل" Then ' حساب الرصيد الحالي في هذا المخزن تحديداً CurrentStock = Application.WorksheetFunction.SumIfs(ws.Range("I:I"), ws.Range("F:F"), ItemName, ws.Range("D:D"), StoreName) - _ Application.WorksheetFunction.SumIfs(ws.Range("I:I"), ws.Range("F:F"), ItemName, ws.Range("C:C"), StoreName) ' المقارنة بين المتاح والمطلوب If RequestedQty > CurrentStock Then MsgBox "عذراً.. الرصيد غير كافٍ في " & StoreName & vbCrLf & _ "الرصيد المتاح هو: " & CurrentStock & " قطعة فقط.", vbCritical, "تنبيه أمان المخزن" Exit Sub ' إيقاف عملية الحفظ End If End If ' ... بقية كود الترحيل والحفظ الذي كتبناه سابقاً ... End Sub Private Sub TxtQty_Change() ' كود إضافي لتحسين تجربة المستخدم On Error Resume Next ' (بافتراض أنك حسبت CurrentStock مسبقاً) If CDbl(TxtQty.Value) > CurrentStock Then TxtQty.BackColor = vbRed TxtQty.ForeColor = vbWhite Else TxtQty.BackColor = vbWhite TxtQty.ForeColor = vbBlack End If End Sub Private Sub Workbook_Open() Dim wsSetup As Worksheet: Set wsSetup = Sheets("Setup") Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim lastRow As Long, i As Long Dim currentBal As Double, reorderLevel As Double Dim itemName As String, msg As String lastRow = wsSetup.Cells(wsSetup.Rows.Count, 1).End(xlUp).Row msg = "الأصناف التالية وصلت لحد الطلب أو أقل:" & vbCrLf For i = 2 To lastRow itemName = wsSetup.Cells(i, 2).Value reorderLevel = wsSetup.Cells(i, 4).Value ' حساب الرصيد الإجمالي للصنف في كل المخازن currentBal = Application.WorksheetFunction.SumIfs(wsTrans.Range("I:I"), wsTrans.Range("F:F"), itemName) - _ Application.WorksheetFunction.SumIfs(wsTrans.Range("I:I"), wsTrans.Range("F:F"), itemName) ' (تعديل بسيط حسب هيكلة مخازنك) If currentBal <= reorderLevel Then msg = msg & "- " & itemName & " (الرصيد الحالي: " & currentBal & ")" & vbCrLf End If Next i If msg <> "الأصناف التالية وصلت لحد الطلب أو أقل:" & vbCrLf Then MsgBox msg, vbExclamation, "تنبيه نقص المخزون" End If End Sub ' يوضع هذا الكود بعد ترحيل حركة الصرف مباشرة في زر الحفظ If (CurrentStock - RequestedQty) <= reorderLevel Then MsgBox "تنبيه: الصنف " & ItemName & " أصبح رصيده منخفضاً جداً!", vbInformation End If Private Sub BtnSave_Click() Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim wsSetup As Worksheet: Set wsSetup = Sheets("Setup") Dim nextRow As Long, CurrentStock As Double, ReorderLevel As Double ' --- 1. التحقق من الرصيد (أمان المخزن) --- If ComboBox1.Value = "صرف" Or ComboBox1.Value = "بيع" Or ComboBox1.Value = "تحويل" Then CurrentStock = Application.WorksheetFunction.SumIfs(wsTrans.Range("I:I"), wsTrans.Range("F:F"), ComboBox4.Value, wsTrans.Range("D:D"), ComboBox2.Value) - _ Application.WorksheetFunction.SumIfs(wsTrans.Range("I:I"), wsTrans.Range("F:F"), ComboBox4.Value, wsTrans.Range("C:C"), ComboBox2.Value) If CDbl(TxtQty.Value) > CurrentStock Then MsgBox "عذراً! الرصيد غير كافٍ. المتاح: " & CurrentStock, vbCritical: Exit Sub End If End If ' --- 2. ترحيل البيانات --- nextRow = wsTrans.Cells(wsTrans.Rows.Count, 1).End(xlUp).Row + 1 With wsTrans .Cells(nextRow, 1).Value = Date .Cells(nextRow, 2).Value = TxtSerial.Value .Cells(nextRow, 3).Value = ComboBox1.Value ' نوع الحركة .Cells(nextRow, 4).Value = ComboBox2.Value ' من مخزن .Cells(nextRow, 5).Value = ComboBox3.Value ' إلى مخزن .Cells(nextRow, 6).Value = ComboBox4.Value ' الصنف .Cells(nextRow, 8).Value = ComboBox6.Value ' الحالة .Cells(nextRow, 9).Value = CDbl(TxtQty.Value) End With ' --- 3. تنبيه حد الطلب بعد العملية --- ' (كود إضافي لفحص حد الطلب من شيت Setup) MsgBox "تمت العملية بنجاح!", vbInformation Unload Me: UserForm1.Show End Sub Private Sub Workbook_Open() ' هنا نضع الكود الذي يمسح الأصناف ويقارن أرصدتها بحد الطلب ' ويظهر رسالة تحذيرية إذا كان (الرصيد <= حد الطلب) Call CheckReorderLevels End Sub Sub CheckExpiryDates() Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim lastRow As Long, i As Long Dim expiryDate As Date Dim msg As String Dim monthsLimit As Integer: monthsLimit = 3 lastRow = wsTrans.Cells(wsTrans.Rows.Count, 1).End(xlUp).Row msg = "تنبيه: الأصناف التالية ستنتهي صلاحيتها خلال 3 أشهر:" & vbCrLf For i = 2 To lastRow ' التحقق من وجود تاريخ صلاحية في العمود J If IsDate(wsTrans.Cells(i, 10).Value) Then expiryDate = wsTrans.Cells(i, 10).Value ' حساب الفرق بين تاريخ اليوم وتاريخ الصلاحية ' DateDiff("m", ...) يحسب الفرق بالشهور If DateDiff("m", Date, expiryDate) <= monthsLimit And expiryDate >= Date Then msg = msg & "- " & wsTrans.Cells(i, 6).Value & " (تنتهي في: " & expiryDate & ")" & vbCrLf End If End If Next i If msg <> "تنبيه: الأصناف التالية ستنتهي صلاحيتها خلال 3 أشهر:" & vbCrLf Then MsgBox msg, vbExclamation, "مراقبة الصلاحية" End If End Sub Private Sub TxtExpiry_Exit(ByVal Cancel As MSForms.ReturnBoolean) If TxtExpiry.Value <> "" Then If Not IsDate(TxtExpiry.Value) Then MsgBox "يرجى إدخال التاريخ بصيغة صحيحة (DD/MM/YYYY)", vbCritical Cancel = True End If End If End Sub Sub ExportExpiryReportToPDF() Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim wsTemp As Worksheet Dim lastRow As Long, i As Long, targetRow As Long Dim fileName As String ' إنشاء شيت مؤقت للتقرير Set wsTemp = Worksheets.Add wsTemp.Name = "Expiry_Report_Temp" ' وضع العناوين wsTemp.Range("A1:D1").Value = Array("الصنف", "المخزن", "الكمية", "تاريخ الصلاحية") wsTemp.Range("A1:D1").Font.Bold = True targetRow = 2 lastRow = wsTrans.Cells(wsTrans.Rows.Count, 1).End(xlUp).Row ' فلترة الأصناف التي ستنتهي خلال 90 يوم For i = 2 To lastRow If IsDate(wsTrans.Cells(i, 10).Value) Then If wsTrans.Cells(i, 10).Value - Date <= 90 And wsTrans.Cells(i, 10).Value >= Date Then wsTemp.Cells(targetRow, 1).Value = wsTrans.Cells(i, 6).Value ' الصنف wsTemp.Cells(targetRow, 2).Value = wsTrans.Cells(i, 4).Value ' المخزن wsTemp.Cells(targetRow, 3).Value = wsTrans.Cells(i, 9).Value ' الكمية wsTemp.Cells(targetRow, 4).Value = wsTrans.Cells(i, 10).Value ' الصلاحية targetRow = targetRow + 1 End If End If Next i ' تنسيق الجدول wsTemp.Columns("A:D").AutoFit ' مسار الحفظ (سطح المكتب) fileName = Environ("USERPROFILE") & "\Desktop\تقرير_الصلاحية_" & Format(Date, "yyyy-mm-dd") & ".pdf" ' تصدير إلى PDF wsTemp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fileName ' حذف الشيت المؤقت Application.DisplayAlerts = False wsTemp.Delete Application.DisplayAlerts = True MsgBox "تم تصدير تقرير PDF بنجاح إلى سطح المكتب باسم: " & vbCrLf & fileName, vbInformation End Sub Sub ExportExpiryToWord() Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim objWord As Word.Application Dim objDoc As Word.Document Dim objTable As Word.Table Dim i As Long, lastRow As Long, targetRow As Long ' إنشاء تطبيق Word جديد Set objWord = New Word.Application objWord.Visible = True ' جعل الوورد مرئياً Set objDoc = objWord.Documents.Add ' إضافة عنوان للمستند With objWord.Selection .Font.Size = 18 .Font.Bold = True .ParagraphFormat.Alignment = wdAlignParagraphCenter .TypeText "تقرير الأصناف التي تقترب صلاحيتها من الانتهاء" .TypeParagraph .Font.Size = 12 .Font.Bold = False .ParagraphFormat.Alignment = wdAlignParagraphRight .TypeText "تاريخ التقرير: " & Date .TypeParagraph: .TypeParagraph End With ' حساب عدد الصفوف التي تنطبق عليها الشروط أولاً لتحديد حجم الجدول lastRow = wsTrans.Cells(wsTrans.Rows.Count, 1).End(xlUp).Row targetRow = 1 ' إضافة جدول (بشكل مبدئي بصف واحد للعناوين) Set objTable = objDoc.Tables.Add(objWord.Selection.Range, 1, 4) objTable.Borders.Enable = True objTable.Cell(1, 1).Range.Text = "الصنف" objTable.Cell(1, 2).Range.Text = "المخزن" objTable.Cell(1, 3).Range.Text = "الكمية" objTable.Cell(1, 4).Range.Text = "تاريخ الصلاحية" objTable.Rows(1).Range.Font.Bold = True objTable.Rows(1).Shading.BackgroundPatternColor = wdColorGray10 ' ملء الجدول بالبيانات المفلترة For i = 2 To lastRow ' فحص الصلاحية (أقل من 90 يوم) If IsDate(wsTrans.Cells(i, 10).Value) Then If wsTrans.Cells(i, 10).Value - Date <= 90 And wsTrans.Cells(i, 10).Value >= Date Then objTable.Rows.Add targetRow = objTable.Rows.Count objTable.Cell(targetRow, 1).Range.Text = wsTrans.Cells(i, 6).Value objTable.Cell(targetRow, 2).Range.Text = wsTrans.Cells(i, 4).Value objTable.Cell(targetRow, 3).Range.Text = wsTrans.Cells(i, 9).Value objTable.Cell(targetRow, 4).Range.Text = wsTrans.Cells(i, 10).Value End If End If Next i ' رسالة تأكيد MsgBox "تم إنشاء مستند Word وتصدير البيانات بنجاح!", vbInformation End Sub Sub UndoTransfer() Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim transID As Variant Dim foundRow As Variant Dim confirm As VbMsgBoxResult ' طلب رقم الإذن المراد التراجع عنه transID = InputBox("يرجى إدخال رقم الإذن (التحويل) المراد التراجع عنه:", "تراجع عن عملية") If transID = "" Then Exit Sub ' إلغاء في حال لم يتم إدخال رقم ' البحث عن رقم الإذن في العمود الثاني foundRow = Application.Match(CLng(transID), wsTrans.Columns(2), 0) If IsError(foundRow) Then MsgBox "عذراً، رقم الإذن غير موجود!", vbCritical Exit Sub End If ' التأكد أن العملية هي "تحويل" If wsTrans.Cells(foundRow, 3).Value <> "تحويل" Then MsgBox "هذا الإذن ليس عملية تحويل، لا يمكن التراجع عنه بهذا الزر!", vbExclamation Exit Sub End If ' تأكيد الحذف confirm = MsgBox("هل أنت متأكد من التراجع عن هذا التحويل؟" & vbCrLf & _ "سيتم حذف السجل وإعادة الكمية للمخزن المصدر.", vbQuestion + vbYesNo, "تأكيد") If confirm = vbYes Then wsTrans.Rows(foundRow).Delete MsgBox "تم التراجع عن العملية بنجاح وتحديث المخزون.", vbInformation ' تحديث أي قوائم أو تقارير مفتوحة Call UpdateListBox End If End Sub Sub UndoTransferWithAudit() Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim wsAudit As Worksheet: Set wsAudit = Sheets("Audit_Log") Dim transID As Variant Dim foundRow As Variant Dim nextAuditRow As Long transID = InputBox("أدخل رقم الإذن للتراجع عنه:", "نظام الرقابة") If transID = "" Then Exit Sub ' البحث عن السجل foundRow = Application.Match(CLng(transID), wsTrans.Columns(2), 0) If Not IsError(foundRow) Then ' 1. تسجيل البيانات في سجل المراقبة قبل الحذف nextAuditRow = wsAudit.Cells(wsAudit.Rows.Count, 1).End(xlUp).Row + 1 With wsAudit .Cells(nextAuditRow, 1).Value = Now ' التاريخ والوقت الحالي .Cells(nextAuditRow, 2).Value = wsTrans.Cells(foundRow, 2).Value ' رقم الإذن .Cells(nextAuditRow, 3).Value = wsTrans.Cells(foundRow, 6).Value ' الصنف .Cells(nextAuditRow, 4).Value = wsTrans.Cells(foundRow, 9).Value ' الكمية .Cells(nextAuditRow, 5).Value = wsTrans.Cells(foundRow, 4).Value ' المخزن المصدر .Cells(nextAuditRow, 6).Value = Application.UserName ' اسم مستخدم الكمبيوتر .Cells(nextAuditRow, 7).Value = "تراجع/حذف تحويل" End With ' 2. تنفيذ الحذف الفعلي wsTrans.Rows(foundRow).Delete MsgBox "تم التراجع وتسجيل العملية في سجل الرقابة.", vbInformation Else MsgBox "رقم الإذن غير موجود!", vbCritical End If End Sub Sub FillUndoList() Dim ws As Worksheet: Set ws = Sheets("Transactions") Dim lastRow As Long, i As Long ListBox2.Clear ListBox2.ColumnCount = 4 ListBox2.ColumnWidths = "50;80;80;50" ' رقم الإذن، الصنف، من، إلى lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row ' عرض آخر 10 حركات تحويل فقط لسهولة التراجع For i = lastRow To 2 Step -1 If ws.Cells(i, 3).Value = "تحويل" Then With ListBox2 .AddItem ws.Cells(i, 2).Value ' رقم الإذن .List(.ListCount - 1, 1) = ws.Cells(i, 6).Value ' اسم الصنف .List(.ListCount - 1, 2) = ws.Cells(i, 4).Value ' من مخزن .List(.ListCount - 1, 3) = ws.Cells(i, 9).Value ' الكمية End With End If If ListBox2.ListCount > 10 Then Exit For Next i End Sub Private Sub CommandButton_Undo_Click() Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim wsAudit As Worksheet: Set wsAudit = Sheets("Audit_Log") Dim transID As Long Dim foundRow As Variant Dim nextAuditRow As Long ' التأكد من اختيار حركة من القائمة If ListBox2.ListIndex = -1 Then MsgBox "يرجى اختيار حركة من القائمة أولاً!", vbExclamation Exit Sub End If ' الحصول على رقم الإذن من العمود الأول في الـ ListBox transID = ListBox2.List(ListBox2.ListIndex, 0) ' البحث عن السجل في شيت الحركات foundRow = Application.Match(transID, wsTrans.Columns(2), 0) If Not IsError(foundRow) Then ' 1. تسجيل العملية في الـ Audit Log المخفي nextAuditRow = wsAudit.Cells(wsAudit.Rows.Count, 1).End(xlUp).Row + 1 wsAudit.Cells(nextAuditRow, 1).Value = Now wsAudit.Cells(nextAuditRow, 2).Value = transID wsAudit.Cells(nextAuditRow, 6).Value = Application.UserName wsAudit.Cells(nextAuditRow, 7).Value = "تراجع عبر اليوزرفورم" ' 2. حذف السجل wsTrans.Rows(foundRow).Delete MsgBox "تم التراجع عن التحويل رقم " & transID & " بنجاح.", vbInformation ' 3. تحديث القائمة فوراً Call FillUndoList End If End Sub

من يساعدنى فى عمل برنامج محاسبى بيع شراء تحويل الدليل المختصر هو ما يضمن استمرارية العمل وحماية النظام من سوء الاستخدام. إليك دليل المستخدم الموحد المصمم ليوضع في شيت باسم "التعليمات" أو يطبع للموظفين: 📘 دليل مستخدم برنامج إدارة المخازن الاحترافي 1️⃣ تسجيل حركة جديدة (إضافة / تحويلات / بيع / شراء) افتح لوحة التحكم واضغط على زر "إضافة حركة". سيقوم البرنامج بإنشاء رقم إذن تلقائي وتاريخ اليوم. اختر نوع الحركة؛ سيقوم النظام بتكييف الخيارات بناءً على اختيارك. اختر المخزن ثم الصنف. سيظهر لك "الرصيد المتاح" فوراً أسفل الصنف. أدخل الكمية؛ إذا تجاوزت الرصيد المتاح في عمليات الصرف، سيتحول لون الخانة للأحمر ويمنعك النظام من الحفظ. اضغط حفظ؛ سيتم ترحيل البيانات وتحديث التقارير فوراً. 2️⃣ عملية التحويل بين المخازن عند اختيار نوع الحركة "تحويل"، سيظهر لك تلقائياً خانة "المخزن المحول إليه". تأكد من اختيار مخزن المصدر (من) ومخزن الهدف (إلى). سيقوم البرنامج بخصم الكمية من الأول وإضافتها للثاني في خطوة واحدة. 3️⃣ التراجع عن العمليات (التصحيح) من داخل اليوزرفورم، انتقل إلى قائمة "التراجع عن الحركات". ستظهر لك قائمة بآخر 10 تحويلات تمت. حدد الحركة التي تريد إلغاءها من القائمة واضغط "تراجع عن الحركة". تنبيه: أي عملية تراجع يتم تسجيلها سرياً في "سجل المراقبة" باسم المستخدم ووقت الحذف. 4️⃣ إدارة تواريخ الصلاحية وحد الطلب عند إدخال صنف جديد، تأكد من إدخال تاريخ الصلاحية. عند فتح الملف، سيعطيك البرنامج تنبيهاً تلقائياً بالأصناف التي ستنتهي خلال 3 أشهر. إذا قل رصيد صنف عن "حد الطلب" المعرف في الإعدادات، سيظهر لك تنبيه بضرورة إعادة الشراء. 5️⃣ استخراج التقارير جرد المخازن: يعطيك الأرصدة الحالية مقسمة (كرتونة / قطعة). كرت الصنف: لمتابعة حركة صنف معين في فترة زمنية محددة. تصدير التقرير: يمكنك تصدير تقارير الصلاحية والنواقص بضغطة زر إلى PDF للإرسال أو Word للتعديل. ⚠️ تعليمات هامة للمدير: تحديث البيانات: لإضافة صنف جديد أو مخزن جديد، اذهب لشيت Setup وأضفه في القائمة. كلمة المرور: لا تشارك كلمة مرور محرر VBA مع الموظفين لضمان عدم عبثهم بالأكواد. الأمان: شيت Audit_Log مخفي تماماً؛ يمكنك الإطلاع عليه من خلال محرر الأكواد فقط لمراقبة عمليات الحذف. هل اكتملت الصورة لديك الآن؟

الف شكر استاذنا / عبدالله بشير عبدالله عندك حق لقد نسيت اضافة البحث فى العمود (G3:U3)

السلام عليكم ورحمة الله وبركاتة الرجاء مساعدتى فى التعديل على هذا الكود طريقة عمل الكود هو ان الهدف الرئيس ينقل وتنسيق البيانات (Data Transformation): يقوم الكود بالبحث عن قيم مطابقة في عمود (W4:W117) ورؤوس أعمدة مطابقة في صف (Y3:AM3)، واستخراج القيم المتقاطعة من جدول مصدر آخر (D4:U...) ولصق النتائج كقيم ثابتة في النطاق (Y4:AM...).التقنية الأساسيةالعمل بالمصفوفات (Arrays): يتم تحميل جميع البيانات (المصدر، قيم البحث، ورؤوس الأعمدة) إلى الذاكرة. تتم عمليات البحث والمعالجة داخل المصفوفات، ويتم لصق النتائج مرة واحدة فقط في نهاية الكود، مما يزيد السرعة بشكل كبير ويقلل من تفاعلات Excel البطيئة.التنظيف والمعالجةيتضمن الكود وظيفة مسبقة لمسح نطاق النتائج القديم (ClearDataRange)، كما يقوم بـ تنظيف النصوص (إزالة المسافات الزائدة وغير القابلة للكسر) لضمان دقة المطابقة، ويتجاهل القيم الصفرية والفارغة عند اللصق.ورقة العمل يستهدف ورقة عمل محددة باسم "الرصيد 3". ولكن المشكلة ان يوجد اصناف بالرغم من مطابقتها مع الاصناف الاخرى لا يتم ترحيل الكمية وفقا لتاريخ التابع لها فما السبب اما بعض الاصناف تعمل بكفائة الكود :- Sub Alternative_CalculateAndPasteValues2() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("الرصيد 3") ' غيّر Dim sourceData As Variant Dim lookupValues As Variant Dim colHeaders As Variant Dim resultArray As Variant Dim i As Long, j As Long, k As Long Dim foundRow As Long, foundCol As Long Call ClearDataRange ' Load all data into arrays for speed sourceData = ws.Range("D4:U" & ws.Cells(ws.Rows.Count, "D").End(xlUp).Row).Value lookupValues = ws.Range("W4:W117").Value colHeaders = ws.Range("Y3:AM3").Value ' Resize the result array ReDim resultArray(1 To UBound(lookupValues, 1), 1 To UBound(colHeaders, 2)) ' Loop through the lookup values For i = 1 To UBound(lookupValues, 1) Dim currentLookupValue As String currentLookupValue = Trim(Replace(lookupValues(i, 1), Chr(160), " ")) ' Manual loop to find the matching row foundRow = 0 For k = 1 To UBound(sourceData, 1) Dim cleanedSourceValue As String cleanedSourceValue = Trim(Replace(sourceData(k, 1), Chr(160), " ")) If StrComp(cleanedSourceValue, currentLookupValue, vbTextCompare) = 0 Then foundRow = k Exit For End If Next k ' If a matching row is found If foundRow > 0 Then ' Loop through the columns For j = 1 To UBound(colHeaders, 2) Dim currentHeader As String currentHeader = Trim(Replace(colHeaders(1, j), Chr(160), " ")) ' Manual loop to find the matching column (on the G:U headers) foundCol = 0 Dim m As Long For m = 1 To 15 ' G to U is 15 columns Dim cleanedHeader As String cleanedHeader = Trim(Replace(ws.Cells(3, m + 6).Value, Chr(160), " ")) If StrComp(cleanedHeader, currentHeader, vbTextCompare) = 0 Then foundCol = m Exit For End If Next m ' If a matching column is found If foundCol > 0 Then Dim resultValue As Variant resultValue = sourceData(foundRow, foundCol + 3) ' +3 to correct for D-G offset ' Place the result in the array, handling zeros and blanks If IsNumeric(resultValue) And CDbl(resultValue) <> 0 Then resultArray(i, j) = resultValue Else resultArray(i, j) = "" End If End If Next j End If Next i ' Paste the final array to the worksheet in one go ws.Range("Y4").Resize(UBound(resultArray, 1), UBound(resultArray, 2)).Value = resultArray End Sub Sub ClearDataRange() ' Clears the contents (data) from the range A4:AM125 Range("Y4:AM125").ClearContents End Sub تنسيق ترتيب الجداول الكمية مع اسم الصنف مع التاريخ التابع له - Copy - Copy.xlsm

الف شكر ا/ hegazee على مساعدته لهذه المشكله

هذا الكود الصحيح بخصوص تنسيق الاعمدة المختلفة من العمود C حتى العمود I هل يمكن اضافة ودمج كود خاص بتنسيق العمود المحدد فى العمود O Sub FormatUniqueCellsInRow() Dim ws As Worksheet Dim lastRow As Long Dim r As Long Dim values(1 To 7) As Variant ' لتخزين القيم من C إلى I (7 أعمدة) Dim i As Integer, j As Integer Dim count As Integer ' 1. إعدادات ورقة العمل Set ws = ThisWorkbook.Sheets("Sheet1") ' ?? غيّر "Sheet1" إلى اسم ورقتك الفعلي ' 2. تحديد آخر صف يحتوي على بيانات في العمود C lastRow = ws.Cells(ws.Rows.count, "C").End(xlUp).Row ' 3. تنظيف أي تنسيقات سابقة من الأعمدة C إلى I ' هذا مهم لضمان تطبيق التنسيقات الجديدة فقط ws.Range("C3:I" & lastRow).Interior.ColorIndex = xlNone ' مسح لون التعبئة ws.Range("C3:I" & lastRow).Font.ColorIndex = xlAutomatic ' مسح لون الخط المخصص ws.Range("C3:I" & lastRow).Font.Bold = False ' إلغاء الخط العريض ' 4. المرور على كل صف بدءًا من الصف 3 (أو أي صف تبدأ منه بياناتك) For r = 3 To lastRow ' ابدأ من الصف الذي تبدأ منه بياناتك ' قراءة القيم من العمود C إلى I للصف الحالي وتخزينها في مصفوفة ' Column C is index 1 (i + 2 where i=1 means 1+2=3 which is C) For i = 1 To 7 values(i) = ws.Cells(r, i + 2).Value ' i+2 لأن C هو العمود الثالث Next i ' فحص كل قيمة في الصف لتحديد إذا كانت فريدة داخل هذا الصف For i = 1 To 7 ' تكرار على كل عمود من C إلى I (بواسطة فهرس المصفوفة i) count = 0 ' إعادة تعيين العداد لكل قيمة ' مقارنة القيمة الحالية (values(i)) بجميع القيم الأخرى في نفس الصف For j = 1 To 7 If values(j) = values(i) Then count = count + 1 End If Next j ' إذا كانت القيمة فريدة (تكررت مرة واحدة فقط في الصف) If count = 1 Then ' تطبيق التنسيق على الخلية المحددة التي تحتوي على القيمة الفريدة With ws.Cells(r, i + 2) ' i + 2 يمثل رقم العمود الفعلي (C, D, E...) .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء (RGB for exact yellow) .Font.Color = RGB(255, 0, 0) ' خط أحمر (RGB for exact red) .Font.Bold = True ' خط عريض End With End If Next i Next r ' إذا كنت لا تزال ترغب في الاحتفاظ بالعمود O بالنص الوصفي، يمكنك ترك الكود الخاص بك ' Sub CheckDifferences() وتشغيله بعد هذا الكود، أو دمج المنطق هنا. ' لكن هذا الكود يركز فقط على تنسيق الخلايا من C إلى I. End Sub

السلام عليكم ورحمة الله وبركاتة الرجاء مساعدتى فى هذه المشكلة يوجد اعمدة بأسماء الاصناف لكل بلد وتم عمل المطلوب من خلال معادلة اكسيل ومعادلة VBA من خلال المعادلة المرتبطة بالكود VBA =GetUniqueColumns(C3:I3) اريد تنسيق العمود O3 الاعمدة المختلفة كل الخلية باللون الاصفر و الحروف باللون الاحمر كما هو مدرج فى الصورة Sub FormatUniqueColumnsDirectly() Dim ws As Worksheet Dim DataRange As Range Dim uniqueColsCollection As New Collection ' This will store the unique column letters Dim cell As Range Dim count As Long Dim colLetter As String Dim targetColumn As Excel.Range Dim i As Long ' --- إعداداتك --- ' 1. تأكد من أن اسم الورقة صحيح Set ws = ThisWorkbook.Sheets("Sheet1") ' غيّر "Sheet1" إلى اسم ورقتك الفعلي ' 2. تأكد من أن نطاق البيانات صحيح ' هذا النطاق هو الذي سيتم البحث فيه عن القيم الفريدة. ' على سبيل المثال، إذا كانت بياناتك في الأعمدة من A إلى Z، ومن الصف 1 إلى الصف 100 Set DataRange = ws.Range("A1:Z100") ' اضبط هذا على نطاق بياناتك الفعلي Debug.Print "Worksheet Name: " & ws.Name Debug.Print "Data Range to check for uniqueness: " & DataRange.Address ' --- الخطوة 1: تحديد الأعمدة الفريدة بناءً على القيم الفريدة داخل النطاق --- ' (هذا هو جوهر ما كانت تفعله دالة GetUniqueColumns) For Each cell In DataRange ' تأكد من أن الخلية ليست فارغة، وإلا فقد يتم عد الخلايا الفارغة كقيم فريدة If Not IsEmpty(cell.Value) Then ' حساب عدد تكرارات القيمة في النطاق الكلي count = Application.WorksheetFunction.CountIf(DataRange, cell.Value) If count = 1 Then ' إذا كانت القيمة فريدة (تظهر مرة واحدة فقط) ' الحصول على حرف العمود من عنوان الخلية (مثال: من $C$5 نحصل على C) colLetter = Split(cell.Address(True, False), "$")(0) Debug.Print "Found unique value: " & cell.Value & " in column: " & colLetter On Error Resume Next ' لتجنب الأخطاء إذا تم إضافة نفس حرف العمود بالفعل uniqueColsCollection.Add colLetter, CStr(colLetter) ' إضافة حرف العمود إلى المجموعة On Error GoTo 0 End If End If Next cell Debug.Print "Number of unique columns identified: " & uniqueColsCollection.count ' --- الخطوة 2: تطبيق التنسيق على الأعمدة الفريدة التي تم تحديدها --- If uniqueColsCollection.count > 0 Then For Each columnLetter In uniqueColsCollection Debug.Print "Attempting to format column: " & columnLetter ' الحصول على كائن العمود بالكامل باستخدام حرف العمود On Error Resume Next ' في حالة كان حرف العمود غير صالح أو فارغ Set targetColumn = ws.Columns(columnLetter) On Error GoTo 0 If Not targetColumn Is Nothing Then Debug.Print "Applying formatting to column: " & columnLetter ' تطبيق التنسيق على العمود المحدد With targetColumn.Interior .Color = RGB(255, 255, 0) ' تعبئة صفراء End With With targetColumn.Font .Color = RGB(255, 0, 0) ' خط أحمر .Bold = True ' خط عريض .Size = 12 ' حجم الخط End With ' إضافة حدود للعمود With targetColumn .Borders(xlEdgeLeft).LineStyle = xlContinuous .Borders(xlEdgeRight).LineStyle = xlContinuous .Borders(xlEdgeTop).LineStyle = xlContinuous .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders.Weight = xlThin ' حدود رفيعة End With targetColumn.ColumnWidth = 15 ' ضبط عرض العمود targetColumn.HorizontalAlignment = xlCenter ' محاذاة النص في المنتصف Else Debug.Print "Error: Could not set targetColumn for letter: " & columnLetter & ". It might be an invalid column letter." End If Set targetColumn = Nothing ' إعادة تعيين المتغير للتكرار التالي Next columnLetter Else MsgBox "لا توجد أعمدة فريدة لتنسيقها في النطاق المحدد.", vbInformation End If ' --- تنظيف المتغيرات --- Set ws = Nothing Set DataRange = Nothing Set uniqueColsCollection = Nothing End Sub ' Keep your GetUniqueColumns function if you still need it for displaying the message Function GetUniqueColumns(DataRange As Range) As String Dim cell As Range Dim uniqueCols As New Collection Dim tempArr() As String Dim result As String Dim i As Long Dim colLetter As String Dim count As Long For Each cell In DataRange count = Application.WorksheetFunction.CountIf(DataRange, cell.Value) If count = 1 Then colLetter = Split(cell.Address(True, False), "$")(0) On Error Resume Next uniqueCols.Add colLetter, CStr(colLetter) On Error GoTo 0 End If Next cell If uniqueCols.count = 0 Then ReDim tempArr(0 To 0) Else ReDim tempArr(1 To uniqueCols.count) For i = 1 To uniqueCols.count tempArr(i) = "العمود " & uniqueCols.Item(i) & " مختلف" Next i End If If UBound(tempArr) = 0 Or uniqueCols.count = 0 Then result = "" ElseIf UBound(tempArr) = 1 Then result = tempArr(1) Else For i = 1 To UBound(tempArr) If i = 1 Then result = tempArr(i) Else result = result & " و " & tempArr(i) End If Next i End If GetUniqueColumns = result End Function 2025 اسم التوكيل.xlsm

اللهم أذهب البأس ربّ النّاس، اشف وأنت الشّافي، لا شفاء إلا شفاؤك، شفاءً لا يغادر سقماً، أذهب البأس ربّ النّاس، بيدك الشّفاء، لا كاشف له إلّا أنت يارب العالمين. - اللهم إنّي أسألك من عظيم لطفك وكرمك وسترك الجميل، أن تشفيه وتمدّه بالصحّة والعافية، لا ملجأ ولا منجا منك إلّا إليك، إنّك على كلّ شيءٍ قدير