مطلوب كود vba لتجميع عناصر المصفوفة

[محمد ايمن]

الاصدقاء الاكارم السلام عليكم و رحمة الله و بركاته

لدي مصفوفة تحتوي على بنود فاتورة

ولكن في بعض الاحيان تتكرر بعص البنود

اريد كود لدمج العناصر المتشابهة مع بعضها 

 

مثلا الصنف (لحم) مكرر اريد ان يتم تجميع الصنف مع بعضه

يجب ان يتم التجميع بشرط نفس رقم الفاتورة و نفس الصنف

المصنف1.xlsb

[AbuuAhmed]

جرب هذا الكود:
بعد تشغيله أول مرة خذ لك نظرة على الفاتورة، ثم شغله مرة ثانية للتخلص من السطور الفارغة.
 

Option Explicit

Sub Macro1()
    Dim row1 As Integer, row2 As Integer, col As Integer
    Dim lRow As Integer, tRow As Integer
    
    On Error Resume Next

    Sheets("الفواتير").Select
    lRow = Range("A1").SpecialCells(xlLastCell).row
    
    Range("A2:I" & lRow).Select
    ActiveWorkbook.Worksheets("الفواتير").ListObjects("الفواتير").Sort.SortFields. _
        Clear
    ActiveWorkbook.Worksheets("الفواتير").ListObjects("الفواتير").Sort.SortFields. _
        Add Key:=Range("الفواتير[رقم الفاتورة]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("الفواتير").ListObjects("الفواتير").Sort.SortFields. _
        Add Key:=Range("الفواتير[الصنف]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("الفواتير").ListObjects("الفواتير").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    tRow = 3
    For row1 = 3 To lRow
        If Cells(row1, 4) <> "" Then
            tRow = row1
            For row2 = row1 + 1 To lRow
                If Cells(row2, 4) = Cells(tRow, 4) And _
                   Cells(row2, 8) = Cells(tRow, 8) Then
                    Cells(tRow, 5) = Cells(tRow, 5) + Cells(row2, 5)
                    For col = 1 To 9
                        Cells(row2, col) = ""
                    Next col
                Else
                    Exit For
                End If
            Next row2
        End If
    Next row1
    
    Range("A3").Select
    
    MsgBox "Done"
End Sub

تم إضافة هذا السطر:
 

    On Error Resume Next

تم التعديل في هذ السطر:
 

    For row1 = 3 To lRow

وإضافة هذين السطرين أيضا:
 

                Else
                    Exit For

 

تم تعديل يناير 10 بواسطه AbuuAhmed
تعديل في الكود

[محمد ايمن]

اخي الكريم @AbuuAhmed

المطلوب ان تتم هذه العملية برمجيا ضمن مصفوفة لا ان يتم تعديل البيانات في صفحة الفواتير

لان البيانات في صفحة الفواتير ثابتة لا يجب ان يتم اي تغيير عليها

ربما لو تمت هذه العملية ضمن صفحة طباعة الفواتير لا مشكلة

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

 

 

 

[AbuuAhmed]

1 ساعه مضت, محمد ايمن said:

المطلوب ان تتم هذه العملية برمجيا ضمن مصفوفة لا ان يتم تعديل البيانات في صفحة الفواتير

هل تريدني أن أواصل أم اكتفيت؟
وإذا كان الجواب نعم فهل تريد المصفوفة تضم كل الأعمدة؟
أخبرني، لأواصل العمل، مع أني لاحظت تواجد أحد الزملاء المتمكنين ولا أعلم أبدأ العمل أم تراجع.

[محمد ايمن]

اخي @AbuuAhmed

وهل فعل الخير يسأل 😅

طبعا واصل العمل جزاك الله كل خير علما ان المصفوفة يجب ان تحوي كل الاعمدة

[AbuuAhmed]

جرب المرفق
اضطررت لعمل صفحة خاصة باسم "مصفوفة"

تم حذف المرفق لوجود هفوة في هذين السطرين:
 

         
        tRow = 2
        For row1 = 2 To lRow

 

تم تعديل يناير 11 بواسطه AbuuAhmed

[محمد هشام.]

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

مع تغيير اسم الورقة المظافة من مصفوفة الى Test 🫣🫣

Sub test1()
Dim wb As Workbook, WSdata As Worksheet, dest As Worksheet, lRow As Long, lCol As Long
Set wb = ThisWorkbook: Set WSdata = wb.Sheets("الفواتير"): Set dest = wb.Sheets("Test")
A = WSdata.Range("A2:I" & WSdata.[D65000].End(xlUp).Row)

With Application
    .ScreenUpdating = False
With dest
    Intersect(.Range(.Rows(2), .UsedRange.Rows(.UsedRange.Rows.Count)), .Range("A:I")).ClearContents
End With

Dim c(): ReDim c(1 To UBound(A, 1), 1 To 9)
Cpt = 0
Set mondico = CreateObject("Scripting.Dictionary")
For I = 1 To UBound(A)
 On Error Resume Next
     clé = A(I, 4) & A(I, 8)
     If Not mondico.exists(clé) Then
     Cpt = Cpt + 1:  mondico.Add clé, Cpt: c(Cpt, 1) = clé: F = Cpt
     Else
       F = mondico.Item(clé)
    End If
 c(F, 1) = A(I, 1): c(F, 2) = A(I, 2): c(F, 3) = A(I, 3): c(F, 4) = A(I, 4): c(F, 5) = c(F, 5) + A(I, 5)
 c(F, 6) = c(F, 6) + A(I, 6): c(F, 7) = c(F, 7) + A(I, 7): c(F, 8) = A(I, 8): c(F, 9) = A(I, 9)
 Next
dest.[a3].Resize(mondico.Count, UBound(c, 2)) = c
lRow = dest.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With dest
        Union(dest.Range("A3:A" & lRow), dest.Range("F3:F" & lRow)).NumberFormat = "#,##0;- #,##0;""-""??"
            dest.Range("C3:C" & lRow).NumberFormat = "dddd dd-mm-yyyy"
            dest.Range("E3:E" & lRow).NumberFormat = "#,##0.0;- #,##0.0;""-""??"
   If dest.ListObjects.Count <> 0 Then Exit Sub
         lCol = .Cells(3, dest.Columns.Count).End(xlToLeft).Column
         dest.ListObjects.Add(xlSrcRange, .Range(dest.Cells(3, 1), .Cells(lRow, lCol)), , xlYes).Name = "Table1"
         .ListObjects("Table1").ShowAutoFilterDropDown = False
    End With
  On Error GoTo 0
.ScreenUpdating = True
  End With
End Sub

 

 

 

تجربة1.xlsb

تم تعديل يناير 11 بواسطه محمد هشام.

[AbuuAhmed]

تم تصحيح هفوة صغيرة مستجدة.
وتم إضافة مجموع القيمة ومتوسط السعر ومجموع السجلات.
بعض النتائج لن تظهر كمتوسط السعر لأن بيانات الفاتورة غير مكتملة.

مرفق الملف مرة أخرى.

 

تحويل الفاتورة إلى مصفوفة_03.xlsb

تم تعديل يناير 11 بواسطه AbuuAhmed

[محمد ايمن]

الاساتذة الاكارم @AbuuAhmed @محمد هشام.

لكم كل التقدير و الاحترام يبدو اني لم اعرف ان اشرح المطلوب بشكل جيد

لدي صفحة للفواتير و صفحة لطباعة الفواتير

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

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

الفكرة التي قدمها الاستاذ @AbuuAhmed ممتازة جدا و قمت بتعديلها لتقوم بالعملية ضمن المصفوفة عوضا عن صفحة الفواتير ثم يتم طباعتها

لكم جزيل الشكر اخوتي الاكارم

 

المصنف1.xlsb