رقم تسلسلي

[nany4mg]

السلام عليكم ورحمة الله الاخوة الكرام 

احتاج في الملف المرفق لسيادتكم عمل تسلسل ل Item NO كل رقم حركة كما هو موضح لسيادتكم في الملف المرفق في عمود serial 

lمع الشكر

مشاركة مكررة .... تـــم بالفعل حذف المشاركة الأخرى , فمن فضلك انتبه لهذا الأمر

تسلسل.xlsm

[سليم حاصبيا]

جرب المعادلة في هذه الصورة

[nany4mg]

استاذي موجود كود ماكرو للاحتساب كل Item NO لكل تاريخ على حدى في الجزء اليمين واحتاج تسلسل Item NO كما هو موضح لسيادتك باللون الاصفر عند تنفيذ الماكرو يتم تجميع كل رقم حركة ب Item NO الخاص بها اتوماتيك اريد بجانب هذا ترقيم كل تل Item NO 

تسلسل.xlsm

[محي الدين ابو البشر]

تــــم تعديل رفع الملف

تسلسل.xlsm

[محي الدين ابو البشر]

الحمد لله أنه تم المطلوب

شكراً و بارك الله بكم

[أحمد يوسف]

بارك الله فيك استاذ محي كود ممتاز

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

وبكده نكون وصلنا لكل طلباتك ويجب غلق المشاركة

[سليم حاصبيا]

احتصار بسيط  للكود المقدم من الاستاذ محي الدين (عسى ان يكون المطلوب)

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

[أحمد يوسف]

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

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

 

[nany4mg]

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

 

[سليم حاصبيا]

تم معالجة الأمر

الخلايا الحمراء في الغامود  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

[nany4mg]

حضرتك نفس المشكلة ممكن ارسل لحضرتك الملف مرة اخرى تشاهد المشكلة 

تسلسل.xlsm

[سليم حاصبيا]

سبق و قلت                                 الخلايا الحمراء في الغامود  D يجب ان تكون فارغة

الكود يعمل بكفاءة عالية  و انت تستعمل ماكرو اخر غير الماكرو الذي كتبته لك 

في هذا الملف تم تنزيل ماكرو وحيد الزر الازرق 

Last_One.xlsm

[nany4mg]

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