اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

الردود الموصى بها

قام بنشر

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

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

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

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

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

 

SALES REPORT.rar

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

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

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

 

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

 

تقبل تحياتى

1.jpg

قام بنشر

هل ستكون عملية البحث في جميع أوراق العمل أم في ورقة 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 وقد أضفت عليه تعديلات لكي يتناسب مع ملفك ..أما بالنسبة للشرح فأمره يطول ، ومحتاج وقت طويل جداً لفهم كل سطر من الأسطر الموجودة ..

تقبل تحياتي

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information