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

[Abo Eslam]

السلام عليكم ورحمه الله .

يوجد لدي جرد في اكثر من صفحة وعندي مثلا بند " مكتب ايديال 3 درج " في اكثر من صفحة اريد تجميع الموجود من الجرد في العمود G لكل صنف في كل الصفحات وعمل صفحة بها كل البنود التي بالعمود D  . اريد جدول من عمودين الاول اسماء الاصناف والثاني الموجود في واقع الجرد لكل صفحات الملف المرفق 

[ياسر خليل أبو البراء]

أخي الكريم اضغط ملفك ثم قم بإرفاقه

مع توضيح بعض النتائج المتوقعة إذا أمكن

[Abo Eslam]

90.rar

[Abo Eslam]

مرفق ملف به المطلوب كما في صفحة الاجمالي 90.rar 

[ياسر خليل أبو البراء]

أخي الكريم أبو إسلام

أهلاً ومرحباً بك في المنتدى ونورت بين إخوانك

 

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

كما يرجى تغيير اسم الظهور للغة العربية لسهولة التواصل

 

إليك الكود التالي لعله يفي بالغرض

Sub UniqueListFromMultipleSheets()
    Dim X, Y(), I&, J&, K&, WS As Worksheet
    ReDim Y(1 To Rows.Count, 1 To 2)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For Each WS In ThisWorkbook.Worksheets(Array("1", "2", "3"))
            X = WS.Range("D10:G" & WS.Cells(Rows.Count, 4).End(xlUp).Row).Value
            For I = 2 To UBound(X)
                If Len(X(I, 1)) Then
                    If .Exists(X(I, 1)) Then
                        K = .Item(X(I, 1))
                        Y(K, 2) = Y(K, 2) + X(I, 4)
                    Else
                        J = J + 1
                        .Item(X(I, 1)) = J
                        Y(J, 1) = X(I, 1)
                        Y(J, 2) = X(I, 4)
                    End If
                End If
            Next I
        Next WS
    End With

    With Sheets("Final")
        .UsedRange.ClearContents
        .Range("A1:B1") = Array("اسم الصنف", "الموجود من واقع الجرد")
        .Range("A2").Resize(J, 2).Value = Y()
    End With
End Sub

لا تنسى أن تحدد أفضل إجابة ليظهر الموضوع مجاب ومنتهي

كما لا تنسى أن تضغط على كلمة "أعجبني هذا" في حال أعجبك الحل المقدم وأدى الغرض

 

تقبل تحياتي

Extract Unique Values From Multiple Sheets YasserKhalil.rar

[Abo Eslam]

شكرا استاذنا الكبير ياسر خليل علي اهتمامكم . وعلي هذا الملف الرائع ولكن استاذي هذا الملف ادي الغرض لثلاث صفحات فقط هي 1 , 2 و 3 ولاكن ملفي به عدد 120 صفحة اريد تطبيق هذا الكود علي ملف به عدد كبير من الصفحات علما بان عدد الاسطر في كل صفحة يزيد علي 30 سطر .

[ياسر خليل أبو البراء]

لم تنوه في المشاركة الأولى عن ذلك الأمر

ولذا أنا دائماً أؤكد على التوضيح التام للطلب حتى لا يطول الموضوع بدون داعي

إليك الكود التالي جربه مع ملفك الأصلي وشوف النتائج صحيحة أم لا ...

إذا كان هناك أوراق عمل أخرى غير 120 وجب التعديل في الكود في السطر التالي

If WS.Name <> "Final" Then

ستضيف أسماء أوراق العمل المراد استثناءها من تنفيذ الكود ...

Sub UniqueListFromMultipleSheets()
    Dim X, Y(), I&, J&, K&, WS As Worksheet
    ReDim Y(1 To Rows.Count, 1 To 2)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For Each WS In ThisWorkbook.Worksheets
            If WS.Name <> "Final" Then
                X = WS.Range("D10:G" & WS.Cells(Rows.Count, 4).End(xlUp).Row).Value
                For I = 2 To UBound(X)
                    If Len(X(I, 1)) Then
                        If .Exists(X(I, 1)) Then
                            K = .Item(X(I, 1))
                            Y(K, 2) = Y(K, 2) + X(I, 4)
                        Else
                            J = J + 1
                            .Item(X(I, 1)) = J
                            Y(J, 1) = X(I, 1)
                            Y(J, 2) = X(I, 4)
                        End If
                    End If
                Next I
            End If
        Next WS
    End With

    With Sheets("Final")
        .UsedRange.ClearContents
        .Range("A1:B1") = Array("اسم الصنف", "الموجود من واقع الجرد")
        .Range("A2").Resize(J, 2).Value = Y()
    End With
End Sub

لا تنسى أن تنهي الموضوع بتحديد أفضل إجابة ليظهر الموضوع مجاب ومنتهي

تقبل تحياتي

[Abo Eslam]

السلام عليكم ا / ياسر

هذا الكود يعطيني خطأ عند السطر 

If Len(X(I, 1)) Then

 

[Abo Eslam]

يظهر هذا الخطأ استاذي عند تغير محتوي خلايا العمود D الي #N/A  مرفق نفس المثال بعد تعديل خلية D15 في الصفحة رقم 3 وعندها لا يعمل الكود . ارجو تعديل Extract Unique Values From Multiple Sheets YasserKhalil.xlsm الكود بحيث يتلاشي عند القراءة اي error في العمود D

[ياسر خليل أبو البراء]

أخي الكريم

يوجد في الخلية D15

في ورقة العمل رقم 3 خطأ

وكيف يكون لاسم صنف خطأ عدد مقابل له في عمود الموجود من الجرد

قم بإرفاق الملف الأصلي لأنه يبدو أنك لم تضع نموذج معبر عن المشكلة من البداية ..

[Abo Eslam]

شكرا اخي الكريم علي الاهتمام مرفق ملف الورقة الاولي من الملف الاصلي وفعلا عمود الاسم يحوي اسم صنف خطأ  Extract Unique Values From Multiple Sheets YasserKhalil.xlsm

[ياسر خليل أبو البراء]

قم بضبط المعادلة VLOOKUP

وذلك بإضافة الدالة

IFERROR

قبل اسم الدالة وفي نهاية المعادلة فاصلة ثم أقواس تنصيص مرتين ثم أغلق القوس

لتكون المعادلة بهذا الشكل

=IFERROR(VLOOKUP(C11,'C:\Users\Mariam\Desktop\New folder\[find.xls]اكواد الاصناف'!$A$1:$IV$65536,3,0),"")

المعادلة كمثال فقط للتطبيق عليها