وعليكم السلام أخي العزيز هاني
أنت لك باع طويل في الإكسيل ويجب عليك أن ترينا محاولاتك من أجل الوصول لحل ..
عموماً إليك الكود التالي مع بعض الملاحظات في الملف المرفق (وأرجو إرفاقه مرة أخرى بعد التصحيح ليستفيد منه الأعضاء)
* يراعى دائماً الدقة في كتابة البيانات .. فعلى سبيل المثال في أوراق العمل المراد الترحيل إليها ستجد أن كلمة HI ACE بها مسافة زائدة في آخر الكلمة ، لذا يجب إزالة هذه المسافة لكي لا يحدث خطأ في تنفيذ الكود ..
* كذلك ملحوظة فيما يخص اسم ورقة العمل Limousin Travel في القائمة المنسدلة بها مسافة في أول الكلمة أما اسم الورقة فليس بها مسافة ، لذا يجب أن تقوم إما بحذف المسافة الزائدة في اسم ورقة العمل في القائمة المنسدلة أو وضع مسافة في أول اسم ورقة العمل في التبويب نفسه.

أخيراً إليك الكود عسى أن يكون المطلوب إن شاء الله

Sub Test()
    Dim x, y, ws As Worksheet, sh As Worksheet, rng As Range, r As Long, m As Long
    
    UseSpeedyCode True
        Set ws = ThisWorkbook.Worksheets("Main")
        For r = 3 To ws.Cells(Rows.Count, 1).End(xlUp).Row
            If Evaluate("ISREF('" & ws.Cells(r, 3).Value & "'!A1)") Then
                 Set sh = ThisWorkbook.Worksheets(ws.Cells(r, 3).Value)
                 m = sh.Cells(Rows.Count, 18).End(xlUp).Row + 1
                 sh.Cells(m, 1).Value = ws.Cells(r, 1).Value
                 sh.Cells(m, 18).Value = ws.Cells(r, 2).Value
                 sh.Cells(m, 19).Resize(1, 2).Value = ws.Cells(r, 7).Resize(1, 2).Value
                 
                 x = Application.Match(ws.Cells(r, 5).Value, sh.Rows(1), 0)
                 If Not IsError(x) Then
                    Set rng = sh.Cells(1, x).Offset(1, -1).Resize(1, 4)
                    y = Application.Match(ws.Cells(r, 6).Value, rng, 0)
                    If Not IsError(y) Then
                        sh.Cells(m, x + y - 2).Value = ws.Cells(r, 4).Value
                    End If
                 End If
            End If
        Next r
    UseSpeedyCode False
    
    MsgBox "Done...", 64
End Sub

Public Function UseSpeedyCode(goFast As Boolean)
    Dim calc As Long
    With Application
        .ScreenUpdating = Not goFast
        .EnableEvents = Not goFast
        If goFast Then
            calc = .Calculation
            .Calculation = xlCalculationManual
        Else
            .Calculation = calc
        End If
    End With
End Function

رائع احسنت استاذ ياسر هذا بالفعل ابداع وتم ضبط الملف طبقاً لملاحظات حضرتك والكود يعمل تمام وبكل كفاءة وتم تعديل الملف بالمشاركة الأولى
ولكن لدى ملاحظة ياريت لو يمكن عملها بالكود وقد اوضحت هذا سلفا وايضا سيتضح لحضرتك من خلال الصورة فلا اريد ان يتم الترحيل على صفوف منفصلة طالما نفس التاريخ ونفس Transfer Type
وياريت لو ممكن عندما يتم الضغط على زر الترحيل لا يتم ترحيل البيانات السابق ترحيلها مرة اخرى فقط يتم ترحيل البيانات الجديدة

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

ليس لدي فكرة عما يمكن تنفيذه في هذه النقطة ولكن كفكرة يمكن الاعتماد عليها أن يكون الاعتماد على التاريخ وعلى النوع Arrival أو Deparature فقط .. وتستخدم WorksheetFunction.Countif لتتاكد أنها تساوي 1 فقط فإذا كانت أكبر من 1 يدل على أنها مكررة ولا يتم ترحيلها

أو أفضل أن تضع عمود مساعد يكون بمثابة رقم مميز لكل عملية .. ننتظر مشاركات الأخوة الأعضاء ربما يفيدوك في حل المشكلة

بارك الله فيك استاذنا الكريم احسن الله اليك ... ولكنى لا اريد بالفعل ترحيل المكرر ولكن فى نفس الوقت اريد تجميع اعداد سيارات التشغيل لهذا المكرر ولكن فى نفس اليوم قد يتكرر التاريخ وايضا يتكرر نوع التشغيلة سواء كانت وصول او سفر ولكن مع اختلاف نوعيات السيارات سواء كانت مثلا اتوبيس أو ميكروباص او غير ذلك
فى النهاية اود شكر حضرتك على هذا العمل الجبار انه فعلا كود ممتاز جعله الله فى ميزان حسناتك

وعليكم السلام ورحمة الله وبركاته
تم التعديل على كود الأستاذ ياسر خليل وان شاء الله يكون المطلوب

Transportatio2 .xlsm