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

[محمد عبد الناصر]

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

مطلوب التعديل على هذا الكود فهو يقوم بتجميع الارقام من العمود 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

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

عليكم السلام

حسب ما فهمت

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

تم تعديل فبراير 25, 2023 بواسطه محي الدين ابو البشر

[محمد عبد الناصر]

منذ ساعه, محي الدين ابو البشر said:

عليكم السلام

حسب ما فهمت

برنامج ترحيل.xlsm 66.42 kB · 2 downloads

ماشاء الله اخي الكريم بارك الله فيك وفي علمك

تم تعديل فبراير 25, 2023 بواسطه محمد عبد الناصر

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

بارك الله