كود تجميع وإستخراج كل صنف على حده

[nany4mg]

السادة الافاضل عندي ملف يوجد به بيانات كثيرة كنت عملت consolidate بدلالة رقم الحركة ولكن الداتا كبيرة  فمحتاج اعمل ماكرو او اي شئ يقوم بعمل consolidate بسرعة  وايضا   تجميع لكل رقم حركة على حدى اتمنى ان اكون اوصلت المشكلة واتمنى المساعدة ضروري جدا  ومرسل ملف للتوضيح 

تــم تعديل وتغيير عنوان المشاركة ليتناسب مع طلبك

توضيح.xlsx

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

تفصل أخي الكريم

توضيح.xlsm

[nany4mg]

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

مع الشكر 

توضيح.xlsm

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

تفضل

توضيح (1).xlsm

[nany4mg]

لف شكر يا استاذي على تعب حضرتك معايا الكود شعال ولكن انا حرسل لحضرتك الملف اللي شغال عليه بطبق الكود مش راضي يشتغل معايا صح التغير الوحيد انه الامتداد من C:C وليس من ِA 

انا عارف اني تعبت حضرتك ممكن تبعتلي تعديل للكود على الملف المرفق جزاك الله كل خير 

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

لساعدتك والاستاذ الفاضل محي

NEW1.xlsm

[أحمد يوسف]

بسيطة -تفضل وبكده تم تلبية كل طلباتك ويجب غلق المشاركة

NEW2.xlsm

[nany4mg]

الف شكر على الاهتمام والمساعدة واتمنى ان لا يكون اي احد من الاخوة الافاضل زعلان مني الف شكر مرة ثانية

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

بعد اذن احي أحمد 

حرب هذا الكود

Option Explicit
Sub Order_by()
Dim Mmax%, i%, y%, t%, NB
Dim Dic As Object, S_lst As Object
Dim ky, x, arr
Dim Sh As Worksheet, Main As Worksheet

Set Sh = Sheets("Salim")
Set Main = Sheets("Sheet1")
Set Dic = CreateObject("Scripting.Dictionary")
Set S_lst = CreateObject("System.Collections.SortedList")

    With Sh.Cells(1, 1)
      .CurrentRegion.Clear
      .Offset(, 3) = "Itemno": .Offset(, 4) = "Pack Qty"
      .Resize(, 7).Interior.ColorIndex = 6
      
    End With

x = 2
 With Main
    Mmax = .Cells(Rows.Count, 1).End(3).Row
    For i = 2 To Mmax + 1
    If Main.Range("A" & i) = vbNullString Then GoTo Next_I
    Dic(Dic.Count) = .Range("A" & i) & "*" & .Range("B" & i) & "*" & _
                     .Range("C" & i) & "*" & .Range("D" & i) & "*" & _
                     .Range("E" & i) & "*" & .Range("F" & i) & "*" & _
                     .Range("G" & i)
     S_lst.Add (.Range("F" & i)) + (i - 2) / 100000, i - 2
     
Next_I:
    Next
End With

 '+++++++++++++++++++++++++++
   For i = 0 To S_lst.Count - 2
     For y = 0 To 6
     arr = Split(Dic.items()(i), "*")
    
      Sh.Cells(x, 1).Offset(, y) = arr(y)
     Next y
     Sh.Cells(x, 1).Offset(, 5) = Round(S_lst.GetKey(i), 2)
     If Int(S_lst.GetKey(i)) = Int(S_lst.GetKey(i + 1)) Then
       x = x + 1
     Else
       Sh.Cells(x + 1, "D") = "Itemno"
       Sh.Cells(x + 1, "E") = "Pack Qty"
       Sh.Cells(x + 1, 1).Resize(, 7).Interior.ColorIndex = 6
       x = x + 2
     End If
      
  Next
Sh.Cells(1, 1).Resize(x - 1, 7).Borders.LineStyle = 1
   Set Dic = Nothing: Set S_lst = Nothing
   Set Sh = Nothing: Set Main = Nothing

 End Sub

الملف مرفق صفحة Salim

nany4mg_1.xlsm

[حسين مامون]

 

 

تم تعديل فبراير 17, 2021 بواسطه حسين مامون

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

تفضل أخي الكريم

NEW1.xlsm