وعليكم السلام
تم نقل الموضوع للقسم المناسب حتى يراه الأعضاء .. في قسم الإكسيل أسئلة وإجابات

بارك الله فيكم

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

Option Explicit
Sub Transfere_data()
Dim M As Worksheet, E As Worksheet
Dim RG_COPY As Range, R%, My_Max%
Dim RG_to As Range, tt%, X%, Answer%
Dim finD_rg As Range
Set M = Sheets("MYTABA3A"): Set E = Sheets("Ejmali")
Set RG_COPY = M.Range("A5").CurrentRegion
R = RG_COPY.Rows.Count
Set RG_COPY = RG_COPY.Resize(R - 1).Offset(1)
X = Application.CountIf(E.Range("B:B"), M.Range("B3"))
If X > 0 Then
 Answer = MsgBox(" The Today's Data is Already exits", vbYesNo)
    If Answer <> 6 Then
      Exit Sub
    Else
      Set finD_rg = E.Range("B:B").Find(M.Range("B3"), lookat:=1)
         With finD_rg.Offset(, -1)
           .Resize(R - 1, 6).ClearContents
           .Resize(R - 1) = RG_COPY.Columns(1).Value
           .Offset(, 1).Resize(R - 1) = M.Range("B3")
           .Offset(, 2).Resize(R - 1, 4).Value = _
           RG_COPY.Columns(2).Resize(, 4).Value
         End With
      Exit Sub
    End If 'For Answer
 End If 'X=0

If R = 1 Then MsgBox "no data to Transfer": Exit Sub
Set RG_to = E.Range("A2").CurrentRegion.Columns(1)
My_Max = RG_to.Rows.Count
My_Max = IIf(My_Max = 1, 3, My_Max + 3)
  
  With E.Cells(My_Max, 1)
    .Resize(R - 1).Value = RG_COPY.Columns(1).Value
    .Offset(, 1).Resize(R - 1).Value = M.Range("b3")
    .Offset(, 2).Resize(R - 1, 4).Value = _
    RG_COPY.Columns(2).Resize(, 4).Value
  End With
End Sub

الملف مرفق للتجربة

بارك الله فيكم وجزاكم الله كل خير
أجرب وأعطيك النتائج
بيض الله وجهك