mahmoud nasr alhasany

احسنت استاذنا / محمد هشام. هذا هو المطلوب

لقد ارفقت لك الملف

Sub تصدير_بيانات_و_تجميعها() Dim wsSource As Worksheet, wsDest As Worksheet Dim lastRow As Long, i As Long, destRow As Long Dim itemCode As String, itemName As String, itemUnit As String Dim itemPrice As Double, cartnCount As Long Dim dict As Object ' Dictionary to store unique items Dim key As Variant ' To loop through dictionary keys efficiently ' Set the source and destination worksheets Set wsSource = ThisWorkbook.Sheets("Sheet3") ' Change "Sheet3" to your source sheet name Set wsDest = ThisWorkbook.Sheets("رصيد") ' Change "رصيد" to your destination sheet name ' Find the last row in the source sheet (start from row 2 to avoid headers) lastRow = wsSource.Cells(Rows.Count, 7).End(xlUp).Row If lastRow < 2 Then Exit Sub ' Exit if no data ' Create a dictionary to store unique items Set dict = CreateObject("Scripting.Dictionary") ' Initialize destination row destRow = 2 ' Start from row 2 (assuming row 1 is for headers) ' Loop through each row in the source sheet For i = 2 To lastRow ' Get item code and name itemCode = Trim(wsSource.Cells(i, 7).Value) ' Trim whitespace itemName = Trim(wsSource.Cells(i, 6).Value) ' Trim whitespace itemUnit = Trim(wsSource.Cells(i, 4).Value) ' Trim whitespace itemPrice = CDbl(wsSource.Cells(i, 5).Value) ' Convert to Double, handle errors later cartnCount = CLng(wsSource.Cells(i, 3).Value) ' Convert to Long, handle errors later ' Skip rows with empty item codes If itemCode = "" Then GoTo NextIteration ' Add new item to dictionary or update existing If Not dict.Exists(itemCode) Then dict.Add itemCode, Array(itemName, itemUnit, itemPrice, cartnCount) Else ' dict(itemCode)(3) = dict(itemCode)(3) + cartnCount End If NextIteration: Next i ' Write headers to the destination sheet With wsDest .Cells(1, 1).Value = "كود الصنف" .Cells(1, 2).Value = "اسم الصنف" .Cells(1, 3).Value = "وحدة الصنف" .Cells(1, 4).Value = "سعر الصنف" .Cells(1, 5).Value = "عدد الكراتين" ' Loop through the dictionary and write data to the destination sheet For Each key In dict.Keys ' More efficient way to loop With .Cells(destRow, 1) .Value = key .Offset(0, 1).Value = dict(key)(0) ' itemName .Offset(0, 2).Value = dict(key)(1) ' itemUnit .Offset(0, 3).Value = dict(key)(2) ' itemPrice .Offset(0, 4).Value = dict(key)(3) ' cartnCount End With destRow = destRow + 1 Next key End With Call جمع_القيم_بشرط_محسن_جدا End Sub Sub جمع_القيم_بشرط_محسن_جدا() Dim wsSheet1 As Worksheet, wsResid As Worksheet Dim lastRowSheet1 As Long, i As Long Dim itemCodeSheet1 As String Dim valueToSum As Double Dim dict As Object ' Dictionary to store sums for each item code ' Set worksheets Set wsSheet1 = ThisWorkbook.Sheets("Sheet3") Set wsResid = ThisWorkbook.Sheets("رصيد") ' Find last row in Sheet1 lastRowSheet1 = wsSheet1.Cells(Rows.Count, 7).End(xlUp).Row ' Check column 7 for last row ' Create a dictionary to store the sums Set dict = CreateObject("Scripting.Dictionary") ' Loop through Sheet1 to sum values For i = 2 To lastRowSheet1 itemCodeSheet1 = CStr(wsSheet1.Cells(i, 7).Value) ' Convert item code to string ' Try converting value to double, handle non-numeric values On Error Resume Next ' Enable error handling valueToSum = CDbl(wsSheet1.Cells(i, 3).Value) ' Try converting to Double On Error GoTo 0 ' Disable error handling ' Add to dictionary or update if exists If dict.Exists(itemCodeSheet1) Then dict(itemCodeSheet1) = dict(itemCodeSheet1) + valueToSum Else dict.Add itemCodeSheet1, valueToSum End If Next i ' Write headers to "رصيد" sheet (if needed) wsResid.Cells(1, 1).Value = "كود الصنف" wsResid.Cells(1, 5).Value = "المجموع" ' Write sums to "رصيد" sheet Dim destRow As Long destRow = 2 ' Start from row 2 Dim key As Variant For Each key In dict.Keys wsResid.Cells(destRow, 1).Value = key wsResid.Cells(destRow, 5).Value = dict(key) destRow = destRow + 1 Next key ' Add total row wsResid.Cells(destRow, 1).Value = "المجموع الكلي" ' Label for total row wsResid.Cells(destRow, 5).Formula = "=SUM(E2:E" & (destRow - 1) & ")" ' Formula to calculate total wsResid.Cells(destRow, 6).Formula = "=SUM(F2:F" & (destRow - 1) & ")" ' Formula to calculate total wsResid.Cells(destRow, 7).Formula = "=SUM(G2:G" & (destRow - 1) & ")" ' Formula to calculate total wsResid.Cells(destRow, 8).Formula = "=SUM(H2:H" & (destRow - 1) & ")" ' Formula to calculate total MsgBox "تمت العملية بنجاح!" End Sub

احسنت استاذنا الغالى / محمد هشام يوجد ملحوظة بسيطة وهى عند تقسيم الموظفين بناء على التاريخ يظهر تنسيق بيانات التاريخ ارقام فى اعمدة معينة وهذا الكود المعدل البسيط بعد اذن استاذنا Option Explicit Sub SplitData() Dim crWS As Worksheet, dest As Worksheet, OnRng As Variant, data As Variant Dim n As Integer, x As Integer, MonthArr As String, sDate As Date Dim lastRow As Long, i As Long, Irow As Long, lr As Long Dim f As Worksheet, arr As Variant, v As Variant Dim dateCol As String ' لتخزين حرف عمود التاريخ Set crWS = Sheets("العقود") dateCol = "J" ' حدد حرف عمود التاريخ هنا arr = Array("العقود", "") lastRow = crWS.Cells(crWS.Rows.Count, dateCol).End(xlUp).Row If lastRow < 5 Then Exit Sub With Application .ScreenUpdating = False: .DisplayAlerts = False .Calculation = xlCalculationManual ' تعطيل العمليات الحسابية للتسريع End With Application.ErrorCheckingOptions.BackgroundChecking = True For Each f In ThisWorkbook.Worksheets If f.Name <> crWS.Name Then v = Application.Match(f.Name, arr, 0) If IsError(v) Then f.Delete End If Next f OnRng = crWS.Range(dateCol & "4:" & dateCol & lastRow).Value ' تصحيح تحويل التاريخ وتنسيقه *قبل* الكتابة إلى الورقة For i = 1 To UBound(OnRng, 1) If Len(OnRng(i, 1)) > 0 Then ' التعامل مع تنسيقات التاريخ المختلفة (بما في ذلك مع وجود نقطتين) If InStr(OnRng(i, 1), ":") > 0 Then OnRng(i, 1) = Replace(OnRng(i, 1), ":", "/") If IsDate(OnRng(i, 1)) Then sDate = CDate(OnRng(i, 1)) n = Month(sDate) x = Year(sDate) MonthArr = Choose(n, "يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", _ "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") Set dest = tmp(MonthArr & " " & x, crWS.Rows(4)) Irow = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1 data = crWS.Range("B" & (i + 3) & ":N" & (i + 3)).Value ' كتابة البيانات dest.Range("B" & Irow).Resize(1, UBound(data, 2)).Value = data ' تعيين تنسيق التاريخ *مباشرة* بعد كتابة التاريخ dest.Cells(Irow, dateCol).NumberFormat = "dd/mm/yyyy" ' تنسيق عمود التاريخ المحدد ' تنسيق الأعمدة H و I و K dest.Cells(Irow, "H").NumberFormat = "dd/mm/yyyy" dest.Cells(Irow, "I").NumberFormat = "dd/mm/yyyy" dest.Cells(Irow, "K").NumberFormat = "dd/mm/yyyy" With dest.Range("A5:A" & dest.Cells(dest.Rows.Count, dateCol).End(xlUp).Row) ' استخدام dateCol هنا أيضًا .Value = Evaluate("ROW(" & .Address & ")-4") End With With dest lr = .Columns("A:N").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row .Columns("A:M").AutoFit .Rows("5:" & lr).RowHeight = 25.5 .Range("A5:M" & lr).HorizontalAlignment = xlCenter .Range("A5:M" & lr).VerticalAlignment = xlCenter ' لا حاجة لتعيين تنسيق الرقم للعمود بأكمله هنا، فقد تم بالفعل End With End If End If Next i crWS.Activate With Application .ScreenUpdating = True: .DisplayAlerts = True .Calculation = xlCalculationAutomatic ' إعادة تمكين العمليات الحسابية End With MsgBox "تم تقسيم الموظفين بنجاح", vbInformation End Sub Function tmp(ShName As String, header As Range) As Worksheet Dim WS As Worksheet On Error Resume Next Set WS = ThisWorkbook.Sheets(ShName) On Error GoTo 0 If WS Is Nothing Then Set WS = Sheets.Add(After:=Sheets(Sheets.Count)) WS.Name = ShName WS.DisplayRightToLeft = True header.Copy WS.Rows(4) End If Set tmp = WS End Function العقود.xlsm

السلام عليكم ورحمة الله وبركاتة يوجد مشكلة فى الكود المدرج يبدو ان المشكلة خاصة بتنسيق بعض البيانات لا يتعامل معها وذلك بسبب بعض الاكواد يبدأ 0 او 00 قبل الرقم يوجد اصناف معينة بعد تصديرها لايقوم بجمع القيم مثل 00744 و 00743 و 02771 و 02770 اما باقى القيم يعمل جيدا مع الاصناف Sub تصدير_بيانات_و_تجميعها() Dim wsSource As Worksheet, wsDest As Worksheet Dim lastRow As Long, i As Long, destRow As Long Dim itemCode As String, itemName As String, itemUnit As String Dim itemPrice As Double, cartnCount As Long Dim dict As Object ' Dictionary to store unique items Dim key As Variant ' To loop through dictionary keys efficiently ' Set the source and destination worksheets Set wsSource = ThisWorkbook.Sheets("Sheet3") ' Change "Sheet3" to your source sheet name Set wsDest = ThisWorkbook.Sheets("رصيد") ' Change "رصيد" to your destination sheet name ' Find the last row in the source sheet (start from row 2 to avoid headers) lastRow = wsSource.Cells(Rows.Count, 7).End(xlUp).Row If lastRow < 2 Then Exit Sub ' Exit if no data ' Create a dictionary to store unique items Set dict = CreateObject("Scripting.Dictionary") ' Initialize destination row destRow = 2 ' Start from row 2 (assuming row 1 is for headers) ' Loop through each row in the source sheet For i = 2 To lastRow ' Get item code and name itemCode = Trim(wsSource.Cells(i, 7).Value) ' Trim whitespace itemName = Trim(wsSource.Cells(i, 6).Value) ' Trim whitespace itemUnit = Trim(wsSource.Cells(i, 4).Value) ' Trim whitespace itemPrice = CDbl(wsSource.Cells(i, 5).Value) ' Convert to Double, handle errors later cartnCount = CLng(wsSource.Cells(i, 3).Value) ' Convert to Long, handle errors later ' Skip rows with empty item codes If itemCode = "" Then GoTo NextIteration ' Add new item to dictionary or update existing If Not dict.Exists(itemCode) Then dict.Add itemCode, Array(itemName, itemUnit, itemPrice, cartnCount) Else ' dict(itemCode)(3) = dict(itemCode)(3) + cartnCount End If NextIteration: Next i ' Write headers to the destination sheet With wsDest .Cells(1, 1).Value = "كود الصنف" .Cells(1, 2).Value = "اسم الصنف" .Cells(1, 3).Value = "وحدة الصنف" .Cells(1, 4).Value = "سعر الصنف" .Cells(1, 5).Value = "عدد الكراتين" ' Loop through the dictionary and write data to the destination sheet For Each key In dict.Keys ' More efficient way to loop With .Cells(destRow, 1) .Value = key .Offset(0, 1).Value = dict(key)(0) ' itemName .Offset(0, 2).Value = dict(key)(1) ' itemUnit .Offset(0, 3).Value = dict(key)(2) ' itemPrice .Offset(0, 4).Value = dict(key)(3) ' cartnCount End With destRow = destRow + 1 Next key End With Call جمع_القيم_بشرط_محسن End Sub Sub جمع_القيم_بشرط_محسن() Dim wsSheet1 As Worksheet, wsResid As Worksheet Dim lastRowSheet1 As Long, lastRowResid As Long Dim i As Long, j As Long Dim itemCodeSheet1 As String, itemCodeResid As String Dim valueToSum As Double, sumValue As Double ' Set worksheets Set wsSheet1 = ThisWorkbook.Sheets("Sheet3") Set wsResid = ThisWorkbook.Sheets("رصيد") ' Find last rows lastRowSheet1 = wsSheet1.Cells(Rows.Count, 1).End(xlUp).Row lastRowResid = wsResid.Cells(Rows.Count, 1).End(xlUp).Row ' Loop through "الرصيد" sheet For j = 2 To lastRowResid itemCodeResid = CStr(wsResid.Cells(j, 1).Value) ' Convert to string sumValue = 0 ' Loop through "شيت1" sheet For i = 2 To lastRowSheet1 itemCodeSheet1 = CStr(wsSheet1.Cells(i, 7).Value) ' Convert to string valueToSum = CDbl(wsSheet1.Cells(i, 3).Value) ' Check if item codes match If itemCodeSheet1 = itemCodeResid Then ' Check if value is numeric to avoid errors If IsNumeric(valueToSum) Then sumValue = sumValue + valueToSum End If End If Next i ' Write the sum to "الرصيد" sheet wsResid.Cells(j, 5).Value = sumValue Next j End Sub اجمالى2 - Copy.xlsm

الرجاء المساعدة

عند الاستعلام عن الاصناف الراكدة على حسب كمية معينة وعدد ايام صلاحية تكون بهذا الشكل ولاكن يوجد مشكلة ان تواريخ أخر حركة فى اوراق المخازن متغيرة ليست مثل العمود c فى ورقة عمل اصناف راكدة تجدها كلها تاريخ واحد وهى 08/10/2024 كما فى هذا الشكل الظاهر فى الصورة

بحث عن الاصناف الراكدة فى المخاذن على حسب اقل كمية والتاريخ بالايام Sub FindStagnantItemsWithCriteria3() ' تعريف الأوراق والمتغيرات Dim wsMain As Worksheet, wsResults As Worksheet Dim wsOther As Worksheet ' تعريف متغير لورقة العمل الأخرى Dim wsOtherSheet As Worksheet ' متغير لتمثيل ورقة عمل المخزن الآخر Dim lastRow As Long, i As Long, lastRowOther As Long ' تعريف lastRowOther Dim item As String, lastMovementDate As Date Dim minQuantity As Integer, productType As String Dim stagnantItems As New Collection Dim stagnantPeriod As Integer Dim otherStores As String Dim otherStoresRange As Range On Error Resume Next ' تحديد الأوراق والمعايير Set wsMain = ThisWorkbook.Sheets("مخزن_الأساسي") ' تحديد أوراق العمل الأخرى كمجموعة Dim wsOtherSheets As Variant wsOtherSheets = Array("مخزن_آخر", "مخزن_آخر 1", "مخزن_آخر 2", "مخزن_آخر 3", "مخزن_آخر 4") ' يمكنك إضافة المزيد هنا ' minQuantity = 10 productType = "أجهزة إلكترونية" ' stagnantPeriod = 90 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' minQuantity = InputBox("أدخل الكمية ولنفترض 10:", "تحديد كمية الرقود") stagnantPeriod = CInt(InputBox("أدخل فترة الركود ولنفترض 90 (بالأيام):", "تحديد فترة الركود")) If stagnantPeriod = 0 Then MsgBox "لم يتم إدخال فترة ركود صحيحة.", vbExclamation Exit Sub End If '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' إنشاء ورقة عمل جديدة للنتائج On Error Resume Next ' لتجنب الخطأ إذا كانت الورقة موجودة بالفعل Set wsResults = ThisWorkbook.Sheets("أصناف_راكدة") On Error GoTo 0 If wsResults Is Nothing Then ' إذا لم تكن الورقة موجودة ، قم بإنشائها Set wsResults = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) wsResults.Name = "أصناف_راكدة" End If ' تحديد الأعمدة بمتغيرات Const colItem As Integer = 1 ' عمود رقم الصنف Const colLastMovement As Integer = 3 ' عمود تاريخ اخر حركة Const colQuantity As Integer = 4 ' عمود الكمية Const colProductType As Integer = 5 ' عمود نوع المنتج Const colOtherStores As Integer = 6 ' عمود جديد للمخازن الأخرى ' عنوان التقرير wsResults.Range("A1").Value = "أصناف راكدة في " & wsMain.Name & " مع معايير إضافية" wsResults.Range("A2:F2").Value = Array("رقم الصنف", "اسم الصنف", "آخر حركة", "الكمية", "نوع المنتج", "مخازن أخرى") ' تحديد الصف الأخير في ورقة العمل الرئيسية lastRow = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row ' البحث عن الأصناف الراكدة وتسجيلها في مجموعة For i = 2 To lastRow item = wsMain.Cells(i, colItem).Value lastMovementDate = wsMain.Cells(i, colLastMovement).Value If DateDiff("D", lastMovementDate, Date) > stagnantPeriod And _ wsMain.Cells(i, colQuantity).Value < minQuantity And _ wsMain.Cells(i, colProductType).Value = productType Then stagnantItems.Add item End If Next i ' كتابة النتائج في ورقة العمل مع تحسينات Dim itemIndex As Variant i = 3 For Each itemIndex In stagnantItems wsResults.Cells(i, colItem).Value = itemIndex wsResults.Cells(i, colItem + 1).Value = wsMain.Cells.Find(What:=itemIndex, LookIn:=xlValues, LookAt:=xlWhole).Offset(0, 1).Value wsResults.Cells(i, colLastMovement).Value = lastMovementDate wsResults.Cells(i, colQuantity).Value = wsMain.Cells(i, colQuantity).Value wsResults.Cells(i, colProductType).Value = wsMain.Cells(i, colProductType).Value ' On Error Resume Next ' لمعالجة الأخطاء إذا لم يتم العثور على الصنف ' البحث في المخازن الأخرى مع تحسينات otherStores = "" ' تهيئة المتغير For Each wsOtherSheet In wsOtherSheets ' استخدام المصفوفة التي تحتوي على أسماء أوراق العمل On Error Resume Next ' لمعالجة الأخطاء إذا لم يتم العثور على الصنف With wsOtherSheet ' استخدام With لتسهيل الرجوع إلى ورقة العمل lastRowOther = .Cells(.Rows.Count, "A").End(xlUp).Row ' تحديد الصف الأخير ديناميكيًا Set otherStoresRange = .Range("A2:F" & lastRowOther) ' تحديد النطاق ديناميكيًا otherStores = Application.WorksheetFunction.VLookup(itemIndex, otherStoresRange, 1, False) End With On Error GoTo 0 If otherStores <> "" Then ' إذا تم العثور على الصنف في المخزن الآخر otherStores = wsOtherSheet.Name & ": " & otherStores & ", " & otherStores ' بناء سلسلة المخازن الأخرى End If Next wsOtherSheet wsResults.Cells(i, colOtherStores).Value = Left(otherStores, Len(otherStores) - 2) ' إزالة الفاصلة الأخيرة i = i + 1 Next itemIndex Call Macro2_Improved_Dynamic End Sub اصناف راكدة 2027ومتحركة.xlsm

بالنسبة لعدد الاصناف الراكدة والمتحركة هذا الكود يعمل اريد كود لعرض كميات الاصناف على حسب كل فرع سواء متحركة او راكدة Sub مقارنة_الاصناف() Const stagnantPeriod As Integer = 90 Dim ws As Worksheet, dest As Worksheet, ShArr As Variant, Ky As Object, KyStagnant As Object Dim lastRow As Long, i As Long, d As Object, cate As Variant, Irow As Long Dim item As String, item_Name As String, Store As String, Movement As Date, C As Variant Dim quantity As Double ShArr = Array("مخزن الرئيسي", "فرع 1", "فرع 2", "فرع 3", "فرع 4", "فرع 5") Set d = CreateObject("Scripting.Dictionary") Set Ky = CreateObject("Scripting.Dictionary") ' لحساب الأصناف المتحركة Set KyStagnant = CreateObject("Scripting.Dictionary") ' لحساب الأصناف الراكدة For Each C In ShArr On Error Resume Next Set ws = ThisWorkbook.Sheets(C) On Error GoTo 0 If ws Is Nothing Then MsgBox "خطأ في الوصول إلى الورقة: " & C, vbCritical: Exit Sub Application.ScreenUpdating = False lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row For i = 2 To lastRow item = ws.Cells(i, 1).Value item_Name = ws.Cells(i, 2).Value Store = ws.Cells(i, 4).Value Movement = ws.Cells(i, 3).Value If item <> "" And Store <> "" Then If IsDate(Movement) Then ' Check for both stagnant and moving items based on the period If DateDiff("d", Movement, Date) > stagnantPeriod Then ' Stagnant item If Not d.Exists(Store) Then d.Add Store, New Collection If Not n(d(Store), item) Then d(Store).Add item If Not KyStagnant.Exists(Store) Then KyStagnant.Add Store, 0 KyStagnant(Store) = KyStagnant(Store) + 1 Else ' Moving item within the period If Not d.Exists(Store) Then d.Add Store, New Collection If Not n(d(Store), item) Then d(Store).Add item Ky(Store) = Ky(Store) + 1 ' Count moving items for the store End If End If End If Next i Next C On Error Resume Next: Set dest = Worksheets("مقارنة الاصناف"): On Error GoTo 0 If dest Is Nothing Then Set dest = Worksheets.Add: dest.Name = "مقارنة الاصناف" Else dest.Cells.ClearContents End If ' Create headers for stagnant and moving items dest.[A1].Resize(1, 3) = Array("المخزن", "عدد الأصناف الراكدة", "عدد الأصناف المتحركة") Irow = 2 On Error Resume Next For Each cate In Ky.Keys dest.Cells(Irow, 1).Value = cate ' Check if there are stagnant items for this store If KyStagnant.Exists(cate) Then dest.Cells(Irow, 2).Value = KyStagnant(cate) ' عدد الأصناف الراكدة End If dest.Cells(Irow, 3).Value = Ky(cate) ' عدد الأصناف المتحركة Irow = Irow + 1 Next cate Application.ScreenUpdating = True End Sub

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

يوجد شيت صلاحية مستخدمين للاستاذ ضاحى Dahy 1234 ZAD IPTV Subscription.xlsm

الرجاء مساعدتى انى عالق Copy of الاصناف الراكدة لكل مخزن(3) - Copy - Copy(1).xlsm

السلام عليكم ورحمة الله وبركاتة تم حل مشكلة الاصناف الراكدة وجلبها فى سيت اصناف راكدة اولا الرجاء مساعدتى فى تنسيق التاريخ فى العمود D ثانيا / اريد مساعدتى فى مقارنة الاصناف الراكدة والمتحركة فى شيت مفصل لتوزيعها والخروج من حالة ركود الاصناف من خلال كل فرع بمعنى ان يوجد صنف بها حالة ركود فى فرع1 ونفس الصنف يوجد بها حركة فى فرع اخر مما يسبب حالة الركود فى انتهاء صلاحية المنتج فعندما اجد الفرع الذى يوجد بها حركة اقوم فورا بأرسالها الى الفرع ملحوظة الافرع عبارة عن محافظات Copy of الاصناف الراكدة لكل مخزن(3) - Copy - Copy.xlsm

اريد استدعاء كل البيانات والاصناف الراكدة بناء على عدد الاصناف الراكدة بالاغلى الاصناف الراكدة لكل مخزن(1) - Copy - Copy.xlsm

الف شكر ا/ محمد هشام للمساعدة هل يمكن اضافة وارفاق كود واسم الصنف والكمية مع التقرير اى البيانات الليس عليها اى حركة او حركتها ضعيفة نسبة للكمية والصلاحية الاصناف الراكدة لكل مخزن(1).xlsm

السلام عليكم ورحمة تالله وبركاتة الرجاء مساعدتى اذا سمحتم يوجد شيت تجريبى نبذة للعمل المطلوب اريد معرفة الاصناف الراكدة والمتحركة لكل مخزن كما هو موضح فى الكود يوجد مشكلة فى الكود لعدم استعراض الاصناف الراكدة وذلك من خلال صلاحية حركة المنتج والكمية Sub FindStagnantItems() Dim ws As Worksheet, wsOutput As Worksheet Dim lastRow As Long, i As Long Dim item As String, category As String, lastMovementDate As Date Dim stagnantItemsByCategory As Object Dim warehouseNames As Variant Dim stagnantPeriod As Integer Dim totalStagnantItemsByCategory As Object ' تحديد الفترة التي تعتبر بعدها الصنف راكدًا stagnantPeriod = 90 ' تحديد أسماء أوراق العمل التي تمثل المخازن warehouseNames = Array("مخزن الرئيسي", "فرع 1") ' إنشاء قاموس لتخزين الأصناف الراكدة حسب التصنيف Set stagnantItemsByCategory = CreateObject("Scripting.Dictionary") Set totalStagnantItemsByCategory = CreateObject("Scripting.Dictionary") ' تكرار العملية لكل مخزن For Each warehouseName In warehouseNames On Error Resume Next Set ws = ThisWorkbook.Sheets(warehouseName) If Err.Number <> 0 Then MsgBox "حدث خطأ في الوصول إلى ورقة العمل: " & Err.Description Exit Sub End If On Error GoTo 0 lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row ' البحث عن الأصناف الراكدة في المخزن الحالي For i = 2 To lastRow item = ws.Cells(i, 1).Value category = ws.Cells(i, 4).Value lastMovementDate = ws.Cells(i, 3).Value If DateDiff("d", lastMovementDate, Date) > stagnantPeriod Then If Not stagnantItemsByCategory.Exists(category) Then stagnantItemsByCategory.Add category, New Collection End If stagnantItemsByCategory(category).Add item ' حساب إجمالي الأصناف الراكدة لكل تصنيف If Not totalStagnantItemsByCategory.Exists(category) Then totalStagnantItemsByCategory.Add category, 1 Else totalStagnantItemsByCategory(category) = totalStagnantItemsByCategory(category) + 1 End If End If Next i Next warehouseName ' إنشاء ورقة عمل جديدة لعرض النتائج Set wsOutput = Worksheets.Add wsOutput.Name = "أصناف راكدة" wsOutput.Range("A1").Value = "التصنيف" wsOutput.Range("B1").Value = "عدد الأصناف الراكدة" ' عرض النتائج Dim categoryName As Variant Dim currentRow As Long currentRow = 2 For Each categoryName In totalStagnantItemsByCategory.Keys wsOutput.Cells(currentRow, 1).Value = categoryName wsOutput.Cells(currentRow, 2).Value = totalStagnantItemsByCategory(categoryName) currentRow = currentRow + 1 Next categoryName End Sub الاصناف الراكدة لكل مخزن.xlsm

بعد استاذنا الرائع / محمد هشام. اولا هذا المجهود بعد فضل الله يرجع للاستاذ محمد هشام و الاستاذ / حسونة حسين لقد تعلمنا منهما الكثير اسأل الله ان يمن عليهم بالخير الكثير هذا الكود VBA بدون ادخال صيغ حسابية فى ورقة العمل فى العمود G وشرحها كالاتى تعطيل الأحداث: نمنع حدوث أي تغييرات أخرى أثناء تنفيذ الكود لتجنب التكرار اللانهائي. التحقق من الخلية المتغيرة: نتأكد من أن الخلية التي تم تغييرها تقع في العمودين F أو E وأنها ضمن نطاق البيانات. التحقق من صحة البيانات: نتأكد من أن القيم المدخلة في الخليتين F و E هي أرقام. إذا كانت القيم غير رقمية، يتم عرض رسالة خطأ للمستخدم. حساب المجموع الكلي: نقوم بضرب قيمة الكمية في سعر الوحدة ونضع النتيجة في العمود G. تحديد ورقة العمل: يتم تحديد الورقة التي تحتوي على البيانات التي تريد تطبيق التنسيق الشرطي عليها. تحديد النطاق: يتم تحديد النطاق الذي يحتوي على القيم التي سيتم تطبيق التنسيق الشرطي عليها. في هذا المثال، يتم تطبيق التنسيق على العمود G بدءًا من الصف الثاني وحتى آخر صف يحتوي على بيانات. حذف التنسيق الشرطي الحالي: يتم حذف أي تنسيق شرطي موجود مسبقًا على النطاق المحدد. إضافة تنسيق شرطي جديد: يتم إضافة شرط جديد حيث يتم تلوين الخلايا باللون الأحمر إذا كانت قيمتها أقل من صفر (أي سالبة). تخصيص التنسيق: يمكنك تغيير لون الخط، حجم الخط، الخط العريض، والمائل وغيرها من خصائص التنسيق حسب رغبتك. Private Sub Worksheet_Change(ByVal Target As Range) ' تحديد ورقة العمل والعمود الأخير للبيانات Dim WS As Worksheet: Set WS = Sheets("فاتورة مبيعات") Dim Lr As Long: Lr = WS.Cells(WS.Rows.Count, "F").End(xlUp).Row ' تعطيل أحداث التغيير مؤقتًا لمنع التكرار اللانهائي Application.EnableEvents = False ' التحقق من أن الخلية المتغيرة تقع في العمودين F أو E If Not Intersect(Target, WS.Range("F:E")) Is Nothing Then ' التأكد من أن الصف المتغير ضمن نطاق البيانات If Target.Row <= Lr Then ' التحقق من أن القيم المدخلة هي أرقام If IsNumeric(Target.Value) And IsNumeric(WS.Cells(Target.Row, "E").Value) Then ' حساب المجموع الكلي وتعيينه في الخلية المناسبة WS.Cells(Target.Row, "G").Value = Target.Value * WS.Cells(Target.Row, "E").Value Call staining_negative_cells Else MsgBox "الرجاء إدخال قيم رقمية صحيحة في عمودي الكمية والسعر." End If End If End If ' إعادة تمكين أحداث التغيير Application.EnableEvents = True End Sub Sub staining_negative_cells() Dim WS As Worksheet Set WS = Sheets("فاتورة مبيعات") ' استبدل باسم الورقة التي تريدها ' تحديد النطاق الذي تريد تطبيق التنسيق الشرطي عليه With WS.Range("G2:G" & WS.Cells(WS.Rows.Count, "G").End(xlUp).Row) .FormatConditions.Delete .FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, Formula1:="0" With .FormatConditions(1).Font .Color = -16776961 ' لون أحمر .Bold = True End With End With End Sub طط.rar

لقد وجدت المشكلة هذا هو الحل Sub Account_fund_balances_Array() Dim LastRow As Long Dim data As Variant Dim i As Long With Worksheets("Sheet4") LastRow = .Cells(.Rows.Count, "I").End(xlUp).Row data = .Range("I2:j" & LastRow).value For i = 2 To UBound(data) If IsNumeric(data(i, 1)) And IsNumeric(data(i, 2)) Then data(i, 1) = data(i, 1) - data(i, 2) + data(i - 1, 1) Else ' استبدال القيم غير الرقمية بصفر (يمكنك تغيير هذه القيمة) data(i, 3) = 0 MsgBox "وجدت قيمة غير رقمية في الصف " & i & ". تم استبدالها بصفر." End If Next i .Range("K2:K" & LastRow).value = data End With End Sub

السلام عليكم ورحمة الله وبركاتة اريد تحديث خزينة الصندوق يوجد مشكله فى الكود Sub RoundedRectangle1_Click() Dim LastRow As Long Dim data As Variant Dim i As Long With Worksheets("خزينة") LastRow = .Cells(.Rows.Count, "I").End(xlUp).Row data = .Range("I2:K" & LastRow).Value For i = 2 To UBound(data) If IsNumeric(data(i, 1)) And IsNumeric(data(i, 2)) Then data(i, 3) = data(i, 1) - data(i, 2) + data(i - 1, 3) Else ' استبدال القيم غير الرقمية بصفر (يمكنك تغيير هذه القيمة) data(i, 3) = 0 MsgBox "وجدت قيمة غير رقمية في الصف " & i & ". تم استبدالها بصفر." End If Next i .Range("K2:K" & LastRow).Value = data End With End Sub اريد كود مثل الخزينة يقوم بعمل طرح من الخلية i2....xlsm

الف شكر استاذنا / ابو عارف لقد تم عمل المطلوب

شكرا جزيلا اخى ابو عارف لقد نجحت العملية وتم اكمال الامر ولاكن كنت اريد تنفيذ الفكرة من خلال اكواد vba من داخل الفورم لقد وجدت اكواد تفعل ذلك ولاكنى عندى صعوبة فى كتابة الارقام باللغة العربية داخل محرر الاكواد كمثال هذ الكود Private Sub CommandButton1_Click() With ListBox1 .AddItem ComboBox1.value .List(.ListCount - 1, 1) = TextBox1.value .List(.ListCount - 1, 2) = ConvertArabicToEnglishWithArabicLetters(TextBox2.value) Me.ListBox1.ColumnCount = 3 Me.ListBox1.ColumnWidths = "40;50;50" End With End Sub Private Function ConvertArabicToEnglishWithArabicLetters(ByVal ArabicText As String) As String Dim i As Integer Dim EnglishText As String Dim ArabicDigits As String Dim EnglishDigits As String ' Define Arabic and English digits 'المفروض داخل علامة التنصيص تكون الارقام عربية ArabicDigits = "0123456789" 'اريد كتابة الارقام هنا بعد علامة التنصيص"ارقام عربية من صفر الى تسعة" 'المفروض داخل علامة التنصيص تكون الارقام انجليزية EnglishDigits = "0123456789" For i = 1 To Len(ArabicText) ' Check if the character is an Arabic digit If InStr(ArabicDigits, Mid(ArabicText, i, 1)) > 0 Then ' Replace Arabic digit with English digit EnglishText = EnglishText & Mid(EnglishDigits, InStr(ArabicDigits, Mid(ArabicText, i, 1)), 1) Else ' Keep the character as it is (including Arabic letters) EnglishText = EnglishText & Mid(ArabicText, i, 1) End If Next i ConvertArabicToEnglishWithArabicLetters = EnglishText End Function

اشكرك على مساعدتى 1 / ابو عارف اريد تنفيذ الكود في حدث بعد تحديث TextBox2 بحيث يظهر فى لليست بوكس الحروف عربية والارقام انجليزية

احسنت استاذنا الغالى / محمد هشام

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

كود برمجي لارسال رساله عبر الواتس اب من الاكسيل الحل المثالي لارسال اكبر عدد من الرسائل من الاكسيل للواتس اب الجديد الكود البرمجي كامل : Sub sendMessage() Dim contact As String Dim text As String num = Application.WorksheetFunction.CountA(Sheets("data").Range("a:a")) - 2 ActiveWorkbook.FollowHyperlink Address:="https://web.whatsapp.com/" Application.Wait (Now + TimeValue("00:00:07")) For I = 0 To num contact = Sheets("data").Range("c2").Offset(I, 0).Value text = Sheets("data").Range("g2").Offset(I, 0).Value Call SendKeys("^%{/}", True) Application.Wait (Now + TimeValue("00:00:05")) Call SendKeys(contact, True) Application.Wait (Now + TimeValue("00:00:05")) Call SendKeys("~", True) Application.Wait (Now + TimeValue("00:00:05")) Call SendKeys(text, True) Application.Wait (Now + TimeValue("00:00:01")) Call SendKeys("~", True) Application.Wait (Now + TimeValue("00:00:01")) Call SendKeys("^%{/}", True) Next I End Sub إرسال رسائل واتساب من إكسل: تُستخدم هذه العبارة بشكل عام للبحث عن طرق إرسال رسائل واتساب من خلال ملف إكسل. ربط إكسل بواتساب: تُشير هذه العبارة إلى البحث عن حلول لربط ملف إكسل بتطبيق واتساب لتمكين إرسال الرسائل تلقائيًا. ماكرو إكسل لإرسال رسائل واتساب: تُستخدم هذه العبارة للبحث عن أكواد ماكرو مخصصة لإكسل تسمح بإرسال رسائل واتساب. أدوات إرسال رسائل واتساب من إكسل: تُشير هذه العبارة إلى البحث عن برامج أو تطبيقات خارجية تعمل كوسيلة وسيطة لإرسال الرسائل من إكسل إلى واتساب. إرسال رسائل واتساب تلقائيًا من إكسل ربط إكسل بواتساب إرسال رسائل واتساب من إكسل . أتمتة واتساب باستخدام إكسل . VBA لربط إكسل بواتساب . ماكرو إكسل لواتساب . وهذا ملف اخر عدلة كما تريد اسهل طريقة ارسال وربط ملف الاكسيل بالواتس اب وارسال رسائل المدرسة او الشركة من الاكسيل للواتس اب.xlsm