mahmoud nasr alhasany

الف شكر لك ا / محمد هشام هذا هو المطلوب عمله

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

الف شكر استاذنا / محمد هشام هذا هو المطلوب هل يمكن اضافة \تنسيق الأرقام فى كود الصنف على ورقة الوورد بحيث تظهر دائمًا بخمسة أرقام مع إضافة أصفار في البداية إذا لزم الأمر (مثل 00245، 02458، 231456) لقد فعلت هذا الخيار ولم يفلح الامر For i = LBound(a) To UBound(a) ' تعديل هنا: تحويل الرقم إلى نص ثم تنسيقه d(i) = Array(a(i, 1), Format(CStr(a(i, 3)), "00000"), a(i, 4), a(i, 6), a(i, 8)) Next i

السلام عليكم ورحمة الله وبركاتة اريد مساعدتى اريد تنسيق البيانات فى جدول الوورد كما هو موضح فى صورة ملف تصدير.xlsm

تمام احسنت الف شكر لك استاذنا الفاضل / محمد هشام

السلام عليكم ورحمة الله وبركاتة يوجد مشكلة فى الكود اريد التعديل على الكود للتعامل مع عدة ملفات مصدر بدلاً من ملف واحد وهى نقل البيانات من عدة ملفات مصدر إلى ملف وجهة واحد. Sub نقل_البيانات_بين_الملفات_محسن() ' تعريف المتغيرات Dim wbDest As Workbook, wbSource As Workbook Dim wsDest As Worksheet, wsSource As Worksheet Dim lastRowDest As Long Dim i As Long, j As Long Dim sourceData As Variant, wsName As String Dim filePath As String Dim fileNames As Variant ' مصفوفة لتخزين أسماء الملفات Dim fileName As Variant Dim sheetNames As Variant Dim sheetName As Variant Dim headers As Variant Dim محافظة As String Dim dataDict As Object ' تعطيل تحديث الشاشة والحساب التلقائي لتسريع التنفيذ Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' تعيين ملف الوجهة (الملف الحالي) Set wbDest = ThisWorkbook ' مصفوفة أسماء الملفات المصدر (يمكنك تعديل هذه القائمة) fileNames = Array("رصيد التوكيلات1.xlsx", "رصيد التوكيلات_كفرالشيخ.xlsx", "رصيد التوكيلات_البحيرة.xlsx", _ "رصيد التوكيلات_طنطا.xlsx", "رصيد التوكيلات_المنصورة.xlsx", "رصيد التوكيلات_دكرنس.xlsx", _ "رصيد التوكيلات_دمياط.xlsx", "رصيد التوكيلات_المنوفية.xlsx", "رصيد التوكيلات_الشرقية.xlsx", _ "رصيد التوكيلات_الاسماعيلية.xlsx", "رصيد التوكيلات_بور سعيد.xlsx", "رصيد التوكيلات_السويس.xlsx", _ "رصيد التوكيلات_المقطم.xlsx", "رصيد التوكيلات_مؤسسة الزكاة.xlsx", "رصيد التوكيلات_الجيزة.xlsx", _ "رصيد التوكيلات_القليوبية.xlsx", "رصيد التوكيلات_الفيوم.xlsx", "رصيد التوكيلات_بنى سويف.xlsx", _ "رصيد التوكيلات_المنيا.xlsx", "رصيد التوكيلات_اسيوط.xlsx", "رصيد التوكيلات_سوهاج.xlsx", _ "رصيد التوكيلات_جرجا.xlsx", "رصيد التوكيلات_قنا.xlsx", "رصيد التوكيلات_نجع حمادى.xlsx", _ "رصيد التوكيلات_الغردقة.xlsx", "رصيد التوكيلات_الاقصر.xlsx", "رصيد التوكيلات_اسوان.xlsx", _ "رصيد التوكيلات_ادفو.xlsx") ' مصفوفة أسماء الأوراق المطلوبة (المحافظات) - يجب أن تتطابق مع أسماء الأوراق في الملفات المصدر sheetNames = Array("الاسكندرية", "كفرالشيخ", "البحيرة", "طنطا", "المنصورة", "دكرنس", _ "دمياط", "المنوفية", "الشرقية", "الاسماعيلية", "بور سعيد", "السويس", _ "المقطم", "مؤسسة الزكاة", "الجيزة", "القليوبية", "الفيوم", "بنى سويف", _ "المنيا", "اسيوط", "سوهاج", "جرجا", "قنا", "نجع حمادى", "الغردقة", "الاقصر", "اسوان", "ادفو") ' إنشاء قاموس لتخزين البيانات من الملفات المصدر Set dataDict = CreateObject("Scripting.Dictionary") ' المرور على كل ملف من ملفات المصدر For Each fileName In fileNames ' بناء مسار الملف الكامل filePath = ThisWorkbook.Path & "\" & fileName ' فتح الملف المصدر مع معالجة الأخطاء On Error Resume Next ' تخطي الخطأ إذا كان الملف مفتوحًا بالفعل Set wbSource = Workbooks(fileName) On Error GoTo 0 If wbSource Is Nothing Then ' إذا لم يتم العثور على الملف المفتوح On Error Resume Next ' تخطي الخطأ إذا لم يتم العثور على الملف Set wbSource = Workbooks.Open(filePath) On Error GoTo 0 If wbSource Is Nothing Then ' إذا لم يتم فتح الملف MsgBox "لم يتم العثور على الملف: " & filePath, vbCritical GoTo SkipFile ' الانتقال إلى الملف التالي End If End If ' المرور على أوراق العمل في الملف المصدر For Each wsSource In wbSource.Sheets محافظة = wsSource.Name ' قراءة البيانات والعناوين من ورقة العمل sourceData = wsSource.Range("B3:S71").Value headers = wsSource.Range("F3:S3").Value ' تخزين البيانات في القاموس باستخدام اسم المحافظة كمفتاح If Not dataDict.Exists(محافظة) Then dataDict.Add محافظة, sourceData End If Next wsSource ' إغلاق الملف المصدر بعد الانتهاء من قراءة البيانات منه wbSource.Close SaveChanges:=False SkipFile: ' علامة لتخطي الملف في حالة عدم وجوده Next fileName ' الآن، dataDict يحتوي على البيانات من جميع الملفات ' المرور على أسماء المحافظات لنقل البيانات إلى الملف الوجهة For Each sheetName In sheetNames ' البحث عن ورقة العمل في ملف الوجهة، وإنشائها إذا لم تكن موجودة On Error Resume Next Set wsDest = wbDest.Sheets(sheetName) On Error GoTo 0 If wsDest Is Nothing Then Set wsDest = wbDest.Sheets.Add(After:=wbDest.Sheets(wbDest.Sheets.Count)) wsDest.Name = sheetName End If ' كتابة العناوين في ورقة العمل إذا كانت فارغة If wsDest.Cells(1, 6).Value = "" Then wsDest.Cells(1, 6).Resize(1, UBound(headers, 2)).Value = headers End If ' إذا كانت البيانات موجودة في القاموس، انقلها إلى ورقة العمل If dataDict.Exists(sheetName) Then sourceData = dataDict(sheetName) ' تحديد الصف الأخير في ورقة العمل lastRowDest = wsDest.Cells(Rows.Count, "F").End(xlUp).Row + 1 ' تعديل لايجاد اخر صف ' تجهيز البيانات للنقل (تخطي الأعمدة من 1 إلى 4) Dim outputData As Variant ReDim outputData(1 To UBound(sourceData, 1), 1 To UBound(sourceData, 2) - 4) For i = 1 To UBound(sourceData, 1) For j = 5 To UBound(sourceData, 2) outputData(i, j - 4) = sourceData(i, j) Next j Next i ' نقل البيانات إلى ورقة العمل wsDest.Range("F" & lastRowDest).Resize(UBound(outputData, 1), UBound(outputData, 2)).Value = outputData End If Next sheetName ' استعادة إعدادات Excel Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "تم نقل البيانات بنجاح.", vbInformation End Sub نقل البيانات بين الملفات.rar

لقد وجدت الحل ايضا واشكر استاذنا / محمد هشام على مساعدتنا فى حل المشكلة وارجح كود ا / محمد هشام Sub نقل_البيانات_بين_الملفات_محسن() Dim wbSource As Workbook, wbDest As Workbook Dim wsSource As Worksheet, wsDest As Worksheet Dim lastRowDest As Long Dim i As Long, j As Long Dim sourceData As Variant, wsName As String Dim filePath As String Dim sheetNames As Variant Dim sheetName As Variant Dim headers As Variant Dim محافظة As String Dim dataDict As Object ' قاموس لتخزين البيانات Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set wbDest = ThisWorkbook filePath = ThisWorkbook.Path & "\رصيد التوكيلات1.xlsx" ' فتح الملف المصدر مع معالجة الأخطاء On Error Resume Next Set wbSource = Workbooks("رصيد التوكيلات1.xlsx") On Error GoTo 0 If wbSource Is Nothing Then On Error Resume Next Set wbSource = Workbooks.Open(filePath) On Error GoTo 0 If wbSource Is Nothing Then MsgBox "لم يتم العثور على الملف: " & filePath, vbCritical Exit Sub End If End If ' مصفوفة أسماء الأوراق المطلوبة sheetNames = Array("الاسكندرية", "كفرالشيخ", "البحيرة", "طنطا", "المنصورة", "دكرنس", _ "دمياط", "المنوفية", "الشرقية", "الاسماعيلية", "بور سعيد", "السويس", _ "المقطم", "مؤسسة الزكاة", "الجيزة", "القليوبية", "الفيوم", "بنى سويف", _ "المنيا", "اسيوط", "سوهاج", "جرجا", "قنا", "نجع حمادى", "الغردقة", "الاقصر", "اسوان", "ادفو") ' إنشاء قاموس لتخزين البيانات Set dataDict = CreateObject("Scripting.Dictionary") For Each wsSource In wbSource.Sheets محافظة = wsSource.Name sourceData = wsSource.Range("B3:S71").Value headers = wsSource.Range("F3:S3").Value ' تخزين البيانات في القاموس dataDict.Add محافظة, sourceData Next wsSource For Each sheetName In sheetNames On Error Resume Next Set wsDest = wbDest.Sheets(sheetName) On Error GoTo 0 lastRowDest = 3 ' ابدأ من الصف الثالث If wsDest Is Nothing Then Set wsDest = wbDest.Sheets.Add(After:=wbDest.Sheets(wbDest.Sheets.Count)) wsDest.Name = sheetName End If If wsDest.Cells(1, 6).Value = "" Then wsDest.Cells(1, 6).Resize(1, UBound(headers, 2)).Value = headers End If If dataDict.Exists(sheetName) Then sourceData = dataDict(sheetName) ' تعديل هنا: تحديد الصف الأخير داخل النطاق F3:S71 lastRowDest = wsDest.Range("F3:F71").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row '+ 1 ' التحقق من وجود اسم المحافظة في مصفوفة sheetNames If IsError(Application.Match(sheetName, sheetNames, 0)) Then ' إذا لم يتم العثور على اسم المحافظة، تخطي هذا الصف Debug.Print "تحذير: اسم المحافظة '" & sheetName & "' غير موجود في قائمة المحافظات." GoTo SkipRow ' انتقل إلى الصف التالي End If Dim outputData As Variant ReDim outputData(1 To UBound(sourceData, 1), 1 To UBound(sourceData, 2) - 4) For i = 1 To UBound(sourceData, 1) For j = 5 To UBound(sourceData, 2) outputData(i, j - 4) = sourceData(i, j) Next j Next i SkipRow: ' تسمية العلامة لتخطي الصف في حالة عدم تطابق اسم المحافظة wsDest.Range("F" & lastRowDest).Resize(UBound(outputData, 1), UBound(outputData, 2)).Value = outputData End If Next sheetName wbSource.Close SaveChanges:=False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub

هل يوجد احد بأمكانة مساعدتى

لقد وجدت الحل ولاكن توجد مشكلة وهى ان استدعاء البيانات بيأخذ وقت كتير لكثرة اوراق العمل هل يوجد كود بديل واسرع من هذا الكود Sub نقل_البيانات_بين_الملفات46() Dim wbSource As Workbook, wbDest As Workbook Dim wsSource As Worksheet, wsDest As Worksheet Dim lastRowSource As Long, lastColSource As Long Dim lastRowDest As Long Dim i As Long, j As Long, k As Long Dim itemCode As String, monthDate As String Dim sourceData As Variant, wsName As String Dim filePath As String Dim wsFoundSource As Boolean Dim sheetNames As Variant Dim sheetName As Variant ' متغير لحلقة التكرار على الأوراق Dim headers As Variant ' متغير لتخزين العناوين Dim محافظة As String Set wbDest = ThisWorkbook ' تحديد مسار الملف المصدر filePath = ThisWorkbook.Path & "\رصيد التوكيلات1.xlsx" ' فتح الملف المصدر مع معالجة الأخطاء On Error Resume Next Set wbSource = Workbooks("رصيد التوكيلات1.xlsx") On Error GoTo 0 If wbSource Is Nothing Then On Error Resume Next Set wbSource = Workbooks.Open(filePath) On Error GoTo 0 If wbSource Is Nothing Then MsgBox "لم يتم العثور على الملف: " & filePath, vbCritical Exit Sub End If End If ' مصفوفة أسماء الأوراق المطلوبة (عدّل هذه الأسماء) sheetNames = Array("الاسكندرية", "كفرالشيخ", "البحيرة", "طنطا", "المنصورة", "دكرنس", _ "دمياط", "المنوفية", "الشرقية", "الاسماعيلية", "بور سعيد", "السويس", _ "المقطم", "مؤسسة الزكاة", "الجيزة", "القليوبية", "الفيوم", "بنى سويف", _ "المنيا", "اسيوط", "سوهاج", "جرجا", "قنا", "نجع حمادى", "الغردقة", "الاقصر", "اسوان", "ادفو") ' تكرار على أوراق العمل في ملف المصدر For Each wsSource In wbSource.Sheets ' الحصول على اسم المحافظة من اسم ورقة العمل محافظة = wsSource.Name ' قراءة البيانات من ورقة العمل الحالية إلى مصفوفة لتسريع العملية sourceData = wsSource.Range("B3:S71").Value ' يشمل كود الصنف والمحافظة ' تخزين العناوين في متغير headers = wsSource.Range("F3:S3").Value ' تكرار على أسماء الأوراق الهدف For Each sheetName In sheetNames ' البحث عن الورقة المطلوبة في ملف الوجهة On Error Resume Next Set wsDest = wbDest.Sheets(sheetName) On Error GoTo 0 ' إذا لم يتم العثور على الورقة في ملف الوجهة، قم بإنشائها If wsDest Is Nothing Then Set wsDest = wbDest.Sheets.Add(After:=wbDest.Sheets(wbDest.Sheets.Count)) wsDest.Name = sheetName End If ' الآن wsDest يشير إلى ورقة العمل الصحيحة، سواء كانت موجودة أو تم إنشاؤها ' تحديد الصف الأخير في ورقة العمل الوجهة بطريقة أكثر دقة lastRowDest = 2 ' ابدأ من الصف الثاني (بعد العناوين) ' كتابة العناوين في ورقة العمل الوجهة (مرة واحدة فقط) ' **فحص ما إذا كانت العناوين موجودة بالفعل قبل كتابتها** If wsDest.Cells(1, 6).Value = "" Then ' إذا كانت الخلية فارغة، فهذا يعني أن العناوين غير موجودة wsDest.Cells(1, 6).Resize(1, UBound(headers, 2)).Value = headers ' كتابة العناوين في الصف الأول، بدءًا من العمود F End If ' إدخال البيانات في ورقة العمل الوجهة If Not IsEmpty(sourceData) Then ' نقل البيانات من المصفوفة إلى ورقة العمل For i = 1 To UBound(sourceData, 1) ' الصفوف في المصفوفة ' التحقق من وجود اسم المحافظة في مصفوفة sheetNames If IsError(Application.Match(محافظة, sheetNames, 0)) Then ' إذا لم يتم العثور على اسم المحافظة، تخطي هذا الصف Debug.Print "تحذير: اسم المحافظة '" & محافظة & "' غير موجود في قائمة المحافظات." GoTo SkipRow ' انتقل إلى الصف التالي End If ' التحقق من تطابق اسم المحافظة مع اسم ورقة العمل الهدف If محافظة = sheetName Then For j = 5 To UBound(sourceData, 2) ' الأعمدة في المصفوفة (من F إلى S) wsDest.Cells(lastRowDest + i, j + 1).Value = sourceData(i, j) ' ابدأ من العمود F (العمود 6) Next j End If SkipRow: ' تسمية العلامة لتخطي الصف في حالة عدم تطابق اسم المحافظة Next i End If Next sheetName Next wsSource ' انتهاء التكرار على أوراق العمل في ملف المصدر ' إغلاق الملف المصدر (اختياري) wbSource.Close SaveChanges:=False End Sub اعتقد ان هذا الكود اسرع ولاكن يقوم بنقل البيانات خارج الجدول لكل محافظ اريد نقل البيانات داخل الجدول مالخطاء هنا Sub نقل_البيانات_بين_الملفات46_محسّن() Dim wbSource As Workbook, wbDest As Workbook Dim wsSource As Worksheet, wsDest As Worksheet Dim lastRowDest As Long Dim i As Long, j As Long Dim sourceData As Variant, wsName As String Dim filePath As String Dim sheetNames As Object ' Dictionary لتخزين أسماء الأوراق Dim sheetName As Variant Dim headers As Variant Dim محافظة As String Dim outputData As Variant Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set wbDest = ThisWorkbook filePath = ThisWorkbook.Path & "\رصيد التوكيلات1.xlsx" ' فتح الملف المصدر مع معالجة الأخطاء On Error Resume Next Set wbSource = Workbooks("رصيد التوكيلات1.xlsx") On Error GoTo 0 If wbSource Is Nothing Then On Error Resume Next Set wbSource = Workbooks.Open(filePath) On Error GoTo 0 If wbSource Is Nothing Then MsgBox "لم يتم العثور على الملف: " & filePath, vbCritical Exit Sub End If End If ' إنشاء Dictionary لتخزين أسماء الأوراق Set sheetNames = CreateObject("Scripting.Dictionary") sheetNames.Add "الاسكندرية", 1 sheetNames.Add "كفرالشيخ", 1 sheetNames.Add "البحيرة", 1 sheetNames.Add "طنطا", 1 sheetNames.Add "المنصورة", 1 sheetNames.Add "دكرنس", 1 sheetNames.Add "دمياط", 1 sheetNames.Add "المنوفية", 1 sheetNames.Add "الشرقية", 1 sheetNames.Add "الاسماعيلية", 1 sheetNames.Add "بور سعيد", 1 sheetNames.Add "السويس", 1 sheetNames.Add "المقطم", 1 sheetNames.Add "مؤسسة الزكاة", 1 sheetNames.Add "الجيزة", 1 sheetNames.Add "القليوبية", 1 sheetNames.Add "الفيوم", 1 sheetNames.Add "بنى سويف", 1 sheetNames.Add "المنيا", 1 sheetNames.Add "اسيوط", 1 sheetNames.Add "سوهاج", 1 sheetNames.Add "جرجا", 1 sheetNames.Add "قنا", 1 sheetNames.Add "نجع حمادى", 1 sheetNames.Add "الغردقة", 1 sheetNames.Add "الاقصر", 1 sheetNames.Add "اسوان", 1 sheetNames.Add "ادفو", 1 For Each wsSource In wbSource.Sheets محافظة = wsSource.Name ' استخدام النطاقات المُعرّفة (تأكد من تعريفها في ملف المصدر) On Error Resume Next ' للتعامل مع الأوراق التي قد لا تحتوي على نطاق مُعرّف sourceData = wsSource.Range("DataRange_" & محافظة).Value On Error GoTo 0 ' إذا لم يتم العثور على النطاق المُعرّف، استخدم النطاق الافتراضي If IsEmpty(sourceData) Then sourceData = wsSource.Range("B3:S71").Value End If headers = wsSource.Range("F3:S3").Value For Each sheetName In sheetNames.Keys On Error Resume Next Set wsDest = wbDest.Sheets(sheetName) On Error GoTo 0 If wsDest Is Nothing Then Set wsDest = wbDest.Sheets.Add(After:=wbDest.Sheets(wbDest.Sheets.Count)) wsDest.Name = sheetName End If lastRowDest = wsDest.Cells(Rows.Count, "F").End(xlUp).Row + 1 If wsDest.Cells(1, 6).Value = "" Then ' إذا كانت الخلية فارغة، فهذا يعني أن العناوين غير موجودة wsDest.Cells(1, 6).Resize(1, UBound(headers, 2)).Value = headers ' كتابة العناوين في الصف الأول، بدءًا من العمود F End If ReDim outputData(1 To UBound(sourceData, 1), 1 To UBound(sourceData, 2) - 4) If Not IsEmpty(sourceData) Then For i = 1 To UBound(sourceData, 1) If محافظة = sheetName Then For j = 5 To UBound(sourceData, 2) outputData(i, j - 4) = sourceData(i, j) Next j End If Next i wsDest.Cells(lastRowDest, 6).Resize(UBound(outputData, 1), UBound(outputData, 2)).Value = outputData End If Next sheetName Next wsSource wbSource.Close SaveChanges:=False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub رصيد التوكيلات1.xlsx رصيد التوكيلات.xlsm

السلام عليكم ورحمة الله وبركاته اريد المساعدة يوجد خطاء فى الكود نقل البيانات من ملف "رصيد التوكيلات1.xlsx" الى ملف "رصيد التوكيلات. XLM" على حسب كود الصنف من B3:B71 وصف التاريخ من F3:S3 والبيانات التابعة لكل صنف من F4:S71 فى ورقة شيت كل محافظة Sub نقل_البيانات_بين_الملفات() Dim wbSource As Workbook, wbDest As Workbook Dim wsSource As Worksheet, wsDest As Worksheet Dim lastRowSource As Long, lastColSource As Long Dim lastRowDest As Long Dim i As Long, j As Long Dim itemCode As String, monthDate As String Dim sourceData As Variant, wsName As String Dim filePath As String Dim wsFoundSource As Boolean Dim sheetNames As Variant Dim sheetName As Variant ' متغير لحلقة التكرار على الأوراق ' تعيين الكائنات Set wbDest = ThisWorkbook ' تحديد مسار الملف المصدر filePath = ThisWorkbook.Path & "\رصيد التوكيلات1.xlsx" ' فتح الملف المصدر مع معالجة الأخطاء On Error Resume Next Set wbSource = Workbooks("رصيد التوكيلات1.xlsx") On Error GoTo 0 If wbSource Is Nothing Then On Error Resume Next Set wbSource = Workbooks.Open(filePath) On Error GoTo 0 If wbSource Is Nothing Then MsgBox "لم يتم العثور على الملف: " & filePath, vbCritical Exit Sub End If End If ' تحديد النطاق في ملف المصدر With wbSource.Sheets(1) ' يمكنك تغيير رقم 1 إلى اسم ورقة العمل إذا كانت مختلفة sourceData = .Range("F4:S71").Value ' تحديد النطاق F4:S71 End With ' مصفوفة أسماء الأوراق المطلوبة (عدّل هذه الأسماء) sheetNames = Array("الاسكندرية", "كفرالشيخ", "البحيرة", "طنطا", "المنصورة", "دكرنس", _ "دمياط", "المنوفية", "الشرقية", "الاسماعيلية", "بور سعيد", "السويس", _ "المقطم", "مؤسسة الزكاة", "الجيزة", "القليوبية", "الفيوم", "بنى سويف", _ "المنيا", "اسيوط", "سوهاج", "جرجا", "قنا", "نجع حمادى", "الاقصر", "اسوان", "ادفو") ' تكرار على أسماء الأوراق For Each sheetName In sheetNames ' البحث عن الورقة المطلوبة في ملف الوجهة On Error Resume Next Set wsDest = wbDest.Sheets(sheetName) On Error GoTo 0 ' إذا تم العثور على الورقة في ملف الوجهة If Not wsDest Is Nothing Then ' إدخال البيانات في ورقة العمل الوجهة If Not IsEmpty(sourceData) Then ' تحديد الصف الأخير في ورقة العمل الوجهة lastRowDest = wsDest.Cells(wsDest.Rows.Count, 2).End(xlUp).Row + 1 ' نقل البيانات من المصفوفة إلى ورقة العمل For i = 1 To UBound(sourceData, 1) ' الصفوف في المصفوفة For j = 1 To UBound(sourceData, 2) ' الأعمدة في المصفوفة wsDest.Cells(lastRowDest + i - 1, j + 5).Value = sourceData(i, j) ' بدءًا من العمود G (العمود 7) Next j Next i End If End If Next sheetName ' إغلاق الملف المصدر (اختياري) wbSource.Close SaveChanges:=False End Sub

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

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

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