nany4mg قام بنشر فبراير 22, 2021 مشاركة قام بنشر فبراير 22, 2021 السلام عليكم ورحمة الله الاخوة الكرام احتاج في الملف المرفق لسيادتكم عمل تسلسل ل Item NO كل رقم حركة كما هو موضح لسيادتكم في الملف المرفق في عمود serial lمع الشكر مشاركة مكررة .... تـــم بالفعل حذف المشاركة الأخرى , فمن فضلك انتبه لهذا الأمر تسلسل.xlsm رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر فبراير 22, 2021 مشاركة قام بنشر فبراير 22, 2021 جرب المعادلة في هذه الصورة رابط هذا التعليق شارك More sharing options...
nany4mg قام بنشر فبراير 22, 2021 الكاتب مشاركة قام بنشر فبراير 22, 2021 استاذي موجود كود ماكرو للاحتساب كل Item NO لكل تاريخ على حدى في الجزء اليمين واحتاج تسلسل Item NO كما هو موضح لسيادتك باللون الاصفر عند تنفيذ الماكرو يتم تجميع كل رقم حركة ب Item NO الخاص بها اتوماتيك اريد بجانب هذا ترقيم كل تل Item NO تسلسل.xlsm رابط هذا التعليق شارك More sharing options...
محي الدين ابو البشر قام بنشر فبراير 22, 2021 مشاركة قام بنشر فبراير 22, 2021 تــــم تعديل رفع الملف تسلسل.xlsm 1 رابط هذا التعليق شارك More sharing options...
محي الدين ابو البشر قام بنشر فبراير 22, 2021 مشاركة قام بنشر فبراير 22, 2021 الحمد لله أنه تم المطلوب شكراً و بارك الله بكم رابط هذا التعليق شارك More sharing options...
أحمد يوسف قام بنشر فبراير 22, 2021 مشاركة قام بنشر فبراير 22, 2021 بارك الله فيك استاذ محي كود ممتاز nany4mg لا يوجد مشكلة كانت حاجة بسيطة وكان يجب عليها إكتشافها بنفسك وهى .... عليك بإستبدال هذا السطر بالكود , بطريق الخطأ من الأستاذ محي تم كتابة i مرتين كما ترى وهذا المتغير لم يكن متعرف بالكود For ii = 1 To IIf(.Count = 1, 1, .Count): Cells(x + 1, 11).Offset(ii - 1, -1) = ii: Next على ان يكون هكذا For i = 1 To IIf(.Count = 1, 1, .Count): Cells(x + 1, 11).Offset(i - 1, -1) = i: Next وبكده نكون وصلنا لكل طلباتك ويجب غلق المشاركة 1 رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر فبراير 22, 2021 مشاركة قام بنشر فبراير 22, 2021 احتصار بسيط للكود المقدم من الاستاذ محي الدين (عسى ان يكون المطلوب) Option Explicit Sub Salim_test() Dim a As Variant, i Dim ar, arr(), x Dim Sh As Worksheet Dim dic As Object x = 1 Set Sh = Sheets("Sheet1") Sh.Range("J1").Resize(10000, 4).ClearContents arr = Array("Item NO", "Pack Qty", "TOTAL") Set dic = CreateObject("scripting.dictionary") For Each ar In Sh.Columns("c:c").SpecialCells(2).Areas a = ar.Offset(1, 3).Resize(ar.Count - 1, 2) For i = 1 To UBound(a) dic(a(i, 1)) = dic(a(i, 1)) + Val(a(i, 2)) Next With Sh.Cells(x, 11) .Resize(, 3) = arr .Offset(1, 2) = WorksheetFunction.Sum(dic.items) .Offset(1).Resize(dic.Count, 2) = _ Application.Transpose(Array(dic.keys, dic.items)) .Offset(1, -1).Resize(dic.Count).Value = _ Evaluate("row(1:" & dic.Count & ")") End With x = x + UBound(a) + 2 dic.RemoveAll Next End Sub nany.xlsm 1 رابط هذا التعليق شارك More sharing options...
أحمد يوسف قام بنشر فبراير 22, 2021 مشاركة قام بنشر فبراير 22, 2021 أخى الكريم ... بالفعل تم تعديل الملف بمشاركة الأستاذ محي شوفها بنفسك , فالأمر لا يتطلب كل هذا وانت تستخدم كود خاطىء , فالكود الصحيح الوارد بمشاركة الأستاذ محي هو Sub test() Dim a As Variant, i Dim ar Dim x x = 1 For Each ar In Columns("c:c").SpecialCells(2).Areas a = ar.Offset(1, 3).Resize(ar.Count - 1, 2) With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If a(i, 1) <> 0 Then If Not .exists(a(i, 1)) Then .Add a(i, 1), a(i, 2) Else .Item(a(i, 1)) = .Item(a(i, 1)) + a(i, 2) End If End If Next Cells(x, 11) = "Item NO": Cells(x, 12) = "Pack Qty": Cells(x, 13) = "TOTAL" Cells(x + 1, 13) = WorksheetFunction.Sum(.items) Cells(x + 1, 11).Resize(.Count, 2) = Application.Transpose(Array(.keys, .items)) For i = 1 To IIf(.Count = 1, 1, .Count): Cells(x + 1, 11).Offset(i - 1, -1) = i: Next x = x + UBound(a) + 2 End With Next End Sub رابط هذا التعليق شارك More sharing options...
nany4mg قام بنشر فبراير 22, 2021 الكاتب مشاركة قام بنشر فبراير 22, 2021 استاذي والله انا طبقت اللي حضرتك بعته نفس المشكلة ودي صورة من الرسالة الخطأ اللي بتظهر رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر فبراير 22, 2021 مشاركة قام بنشر فبراير 22, 2021 تم معالجة الأمر الخلايا الحمراء في الغامود D يجب ان تكون فارغة ( لأن الماكرو يتعامل مغ الخلايا غير الفارغة في هذا العامود D فقط ) Option Explicit Sub Salim_test() Dim i%, Ro% Dim arr(), Ara As Range Dim Sh As Worksheet Dim dic As Object Dim R_D As Range Set Sh = Sheets("Sheet1") Ro = Sh.Cells(Rows.Count, 3).End(3).Row Set R_D = Sh.Range("D1:D" & Ro).SpecialCells(2, 23) Sh.Range("J2").Resize(Ro, 4).ClearContents arr = Array("Item NO", "Pack Qty", "TOTAL") Set dic = CreateObject("scripting.dictionary") For Each Ara In R_D.Areas For i = 1 To Ara.Rows.Count dic(Ara.Cells(i).Offset(, 2).Value) = _ dic(Ara.Cells(i).Offset(, 2).Value) _ + Val(Ara.Cells(i).Offset(, 3)) Next i With Ara.Cells(1).Offset(-1, 7) .Resize(, 3) = arr .Offset(1, 2) = WorksheetFunction.Sum(dic.items) .Offset(1).Resize(dic.Count, 2) = _ Application.Transpose(Array(dic.keys, dic.items)) .Offset(1, -1).Resize(dic.Count).Value = _ Evaluate("row(1:" & dic.Count & ")") End With dic.RemoveAll Next Ara Set Ara = Nothing: Set Sh = Nothing Set dic = Nothing: Set R_D = Nothing Erase arr End Sub TASALSUL.xlsm 1 رابط هذا التعليق شارك More sharing options...
nany4mg قام بنشر فبراير 22, 2021 الكاتب مشاركة قام بنشر فبراير 22, 2021 حضرتك نفس المشكلة ممكن ارسل لحضرتك الملف مرة اخرى تشاهد المشكلة تسلسل.xlsm رابط هذا التعليق شارك More sharing options...
أفضل إجابة سليم حاصبيا قام بنشر فبراير 22, 2021 أفضل إجابة مشاركة قام بنشر فبراير 22, 2021 سبق و قلت الخلايا الحمراء في الغامود D يجب ان تكون فارغة الكود يعمل بكفاءة عالية و انت تستعمل ماكرو اخر غير الماكرو الذي كتبته لك في هذا الملف تم تنزيل ماكرو وحيد الزر الازرق Last_One.xlsm رابط هذا التعليق شارك More sharing options...
nany4mg قام بنشر فبراير 22, 2021 الكاتب مشاركة قام بنشر فبراير 22, 2021 ربنا يبارك فيك تمام كده انا متشكر جدا جدا على المجهود المبذل من سيادتكم عاجز على الشكر 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان