تجميع البيانات من عدة ملفات اكسيل الى ملف اكسيل واحد لكل عامل

[ابو تالين]

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

وكل عام وانتم جميعا بخير

برجاء من خبراء المنتدى العظيم المساعدة فى عمل هذا الملف والشرح كالتالى :-

يتم عمل ملف يومي لجميع السائقين من حيث عدد TRIP AND EXTRA TRIP  لكل سائق ومساعده على حدى وفى نهاية الشهر يتم تجميع عدد التريبات خلال الشهر من كل ملفات الاكسيل لكل سائق ومساعده على حدى.

مثال للتوضيح يوجد فى الملف SALES REPORT 01-09-2016 سائق اسمه BABU RAM BHUSAL فى الخلية رقم E17 المطلوب البحث عنه فى جميع الملفات الموجودة داخل نفس الفولدر والحصول على رقم عدد التربات وجمعها جميعا ووضع الناتج له فى الملف TOTAL فى الخانة D2 وكذالك باقى الأعمدة.

SALES REPORT.rar

[ابو تالين]

برجاء المساعده للأهمية يا جماعة الخير

[ابو تالين]

UP

[ابو تالين]

هو الموضوع صعب اوى كده ؟

[ابو تالين]

UP

 

[ابو تالين]

UP

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

ممكن توضح شكل النتائج المتوقعة حتى يتسنى للأخوة الأعضاء المشاركة الإيجابية ..دعم طلبك بالصور إذا أمكن

[ابو تالين]

منذ ساعه, ياسر خليل أبو البراء said:

ممكن توضح شكل النتائج المتوقعة حتى يتسنى للأخوة الأعضاء المشاركة الإيجابية ..دعم طلبك بالصور إذا أمكن

تفضل اخى الكريم , صورة من للتوضيح وقد قمت بفتح جميع ملفات الاكسيل الموجودة داخل نفس الفولدر ووضع الشرح عليها على شكل اسهم واتجهات اى المطلوب البحث عن اسم كل سائق فى جميع ملفات الاكسيل وجلب الرقم الموجود فى خانة Total Trip من جميع الملفات وجمعهم ووضع المجموع فى ورقة الاعمل النهائية التى بأسم TOTAL  امام اسمه.

 

اتمنى ان اكون قدرت ان اوصل الفكرة .. واذا اردت اى استفسار لا تتردد بسألى عنه

 

تقبل تحياتى

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

هل ستكون عملية البحث في جميع أوراق العمل أم في ورقة Summary Report فقط؟

وهل المطلوب عمل ملخص أي يتم جلب أسماء السائقين ثم حساب العدد الإجمالي لكل منهم ؟ أم أن أسماء السائقين مسجلة بالفعل وتريد إجراء عملية العد بناءً على نتائج عملية البحث؟

وهل عملية البحث ستشمل جميع الجداول الموجودة ؟

ولي سؤال لما لا يتم تجميع الجداول في جدول واحد فقط .. !!؟

[ابو تالين]

18 دقائق مضت, ياسر خليل أبو البراء said:

هل ستكون عملية البحث في جميع أوراق العمل أم في ورقة Summary Report فقط؟

وهل المطلوب عمل ملخص أي يتم جلب أسماء السائقين ثم حساب العدد الإجمالي لكل منهم ؟ أم أن أسماء السائقين مسجلة بالفعل وتريد إجراء عملية العد بناءً على نتائج عملية البحث؟

وهل عملية البحث ستشمل جميع الجداول الموجودة ؟

ولي سؤال لما لا يتم تجميع الجداول في جدول واحد فقط .. !!؟

اخى الفاضل/ ياسر خليل

- ستكون عملية البحث فى Summary Report فقط .

- أسماء السائقين مسجلة بالفعل فى ملف اسمه TOTAL وهذا الملف بهم جميع اسماء السائقين وأريد إجراء عملية العد بناءً على نتائج عملية البحث .

- عملية البحث ستشمل 2 جدول الاول بأسم Driver Name  والجدول الثانى بأسم Helper Name  ودخل كل جدول يوجد اسمائهم .

- سبب انفصال الجداول لأن كل جدول يخص مجموعة معينة مثلا الجدول بأسم Driver Name  هو فقط يوجد بداخله اسماء السائقين فقط وأيضا الجدول بأسم Helper name يوجد بداخله فقط اسماء المساعدين.

وبعد مساعدت حضرتك لى فى هذا الجزء  الخاص بورقة العمل  Summary Repoert سوف اطبق الحل فى جميع اوارق العمل الأخرى مع اضافة التعديلات .

 

ولك منى جزيل الشكر...

 

 

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

سؤال أخير إن شاء الله

هل الجداول التي يتم فيها البحث ثابتة أي تبدأ دائماً في نفس عناوين الخلايا؟أم أنها غير ثابتة؟

وهل عدد الجداول المطلوب البحث فيها ثابت أم متغير؟

[ابو تالين]

10 ساعات مضت, ياسر خليل أبو البراء said:

سؤال أخير إن شاء الله

هل الجداول التي يتم فيها البحث ثابتة أي تبدأ دائماً في نفس عناوين الخلايا؟أم أنها غير ثابتة؟

وهل عدد الجداول المطلوب البحث فيها ثابت أم متغير؟

الله يكرمك اخى الكريم..

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

اما بخصوص عدد الجداول فهو ثابت .

 

 

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

أخي الكريم سامح

قم بفك الضغط عن ملفاتك ثم ضع الأربعة ملفات داخل مجلد وليكن باسم Sameh

الآن قم بفتح المصنف المسمى Total ثم اضغط من لوحة المفاتيح Alt + F11 للدخول لمحرر الأكواد ثم من قائمة Insert قم بإدراج موديول جديد Module

ضع الكود التالي في الموديول الذي تم إدراجه

'https://www.officena.net/ib/topic/71793-*
'=========================================

Sub Test()
    Dim coll As New Collection, rngSrc As Range, rngTgt As Range, arr(), arrTemp()
    Dim I As Long, J As Long, P As Long, strKey As String, v

    Set rngSrc = ThisWorkbook.Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 13)
    Set rngSrc = rngSrc.Offset(1).Resize(rngSrc.Rows.Count - 2)
    rngSrc.Columns("D:F").ClearContents
    rngSrc.Columns("K:M").ClearContents
    arr = rngSrc.Value
    
    For I = 1 To UBound(arr, 1)
        On Error Resume Next
            coll.Add Key:="LEFT" & arr(I, 2), Item:=I
            coll.Add Key:="RIGHT" & arr(I, 9), Item:=I
        On Error GoTo 0
    Next I

    Application.ScreenUpdating = False
        v = Dir(ThisWorkbook.Path & "\*.xlsx")
        
        While v <> ""
            With Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & v, ReadOnly:=True)
                With .Sheets("Summary Report ").UsedRange
                    Set rngTgt = .Find(What:="Driver Name", After:=.Cells(.Rows.Count, .Columns.Count))
                    If Not rngTgt Is Nothing Then
                        arrTemp = rngTgt.CurrentRegion.Resize(, 15).Value
                        
                        For I = 2 To UBound(arrTemp, 1) - 1
                            strKey = "LEFT" & arrTemp(I, 3)
                            
                            If coll_isExists(coll, strKey) Then
                                P = coll(strKey)
                                For J = 5 To 7
                                    arr(P, J - 1) = arr(P, J - 1) + arrTemp(I, J)
                                Next J
                            End If
                            
                            strKey = "RIGHT" & arrTemp(I, 11)
                            If coll_isExists(coll, strKey) Then
                                P = coll(strKey)
                                For J = 13 To 15
                                    arr(P, J - 2) = arr(P, J - 2) + arrTemp(I, J)
                                Next J
                            End If
                        Next I
                    End If
                End With
                
                Application.DisplayAlerts = False
                    .Close SaveChanges:=False
                Application.DisplayAlerts = True
            End With
            v = Dir
        Wend
    
        For Each v In Array(4, 5, 6, 11, 12, 13)
            For I = 1 To UBound(arr, 1)
                If arr(I, v) = "" Then arr(I, v) = 0
            Next I
        Next v
    
        rngSrc.Value = arr
    Application.ScreenUpdating = True
End Sub

Private Function coll_isExists(coll As Collection, strKey As String) As Boolean
    On Error Resume Next
    With coll(strKey)
        If Err.Number = 0 Then coll_isExists = True Else coll_isExists = False
    End With
End Function

احفظ المصنف ، ستظهر لك رسالة اختر منها No ثم اختر نوع الحفظ Macro-Enabled Workbook (ليتم حفظ الأكواد)

أغلق المصنف ثم افتح المجلد المسمى Sameh ، وقم بحذف المصنف Total والذي امتداد xlsx وأبقي على المصنف الجديد المسمى Total والذي امتداده xlsm

الآن افتح المصنف الجديد Total ثم اضغط Alt + F8 ليظهر لك قائمة اختر منها اسم الإجراء الفرعي المطلوب تنفيذه ، ثم انقر Run لتنفيذ الماكرو

وراجع النتائج للتأكد من عمل الكود

رابط الملف من هنا

تقبل تحياتي

 

[ابو تالين]

جزاك الله خيرا اخى ياسر خليل

وزاده في ميزان حسانتك  وزادك الله علما علم ونورا على نور

هو المطلوب جملة وتفصيلا

ولكن هل من الممكن شرح للكود لكى استطيع التعديل عليه واستخدامه فى امور اخرى ومشابهه.

لك كل الشكر والتقدير

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

وجزيت خيراً أخي الكريم سامح

ومشكور على دعائك الطيب والحمد لله أن تم المطلوب على خير ..

الكود ليس لي إنما هو لشخص يدعى Karedog وقد أضفت عليه تعديلات لكي يتناسب مع ملفك ..أما بالنسبة للشرح فأمره يطول ، ومحتاج وقت طويل جداً لفهم كل سطر من الأسطر الموجودة ..

تقبل تحياتي