تعديل على كود تجميع ارقام محددة من شيتات

**محمد عبد الناصر** · فبراير 23, 2023

السلام عليكمورحمة الله وبركاته ,,,

مطلوب التعديل على هذا الكود فهو يقوم بتجميع الارقام من العمود D8 ويضع الناتج في شيت "بيان الاربح" في العمود C5 ويقوم بتجميع الارقام من العمود F8 ويضع الناتج في "شيت الارباح" في العمود D5 ثم يقوم بعمليه حسابية الضرب ويظهر الناتج في العمود G8 على حسب اسم الصنف المكتوب في العمود B8 في شيت بيان الارباح

المطلوب ان يقوم يتجميع الارقام من جميع الشيتات من العمود D10 ويضعها في شيت "بيان المخزن" في العمود D10 ويجمع الارقام من جميع الشيتات من العمود E10 ويضعها في العمود E10 في شيت " بيان المخزن"

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

وان امكن ان يتم تطبيقه في الملف المرفق

Option Explicit

Sub test()
Dim a, x, w
Dim i&
Dim sht As Worksheet
x = Array("بيانات المخزن", "المدخلات", "مديونيات العميل", "المرتجع")
Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
With CreateObject("scripting.dictionary")
        For Each sht In ActiveWorkbook.Worksheets
             If IsError(Application.Match(sht.Name, x, 0)) Then
             a = sht.Cells(8, 1).Resize(sht.Cells(Rows.Count, 1).End(xlUp).Row - 7, 7)
                For i = 1 To UBound(a)
                    If Not .exists(a(i, 2)) Then
                 .Add a(i, 2), Array(a(i, 4), a(i, 3) * a(i, 4), a(i, 7))
            Else
         w = .Item(a(i, 2))
        w(0) = w(0) + a(i, 4): w(1) = w(1) + a(i, 3) * a(i, 4): w(2) = w(2) + a(i, 7)
        .Item(a(i, 2)) = w
        End If
            Next
        End If
    Next
For i = 5 To Range(Cells(5, 2), Cells(5, 2).End(xlDown)).Count
       If Cells(i, 2) = "" Then Exit Sub
    If Not .exists(Cells(i, 2)) Then Cells(i, 4).Resize(, 3) = .Item(Cells(i, 2).Value)
    Next
End With
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
End Sub

برنامج الترحيل.xlsm