السلام عليكم ورحمة الله
استخدم هذا الكود و لا تمسح او تلغى الكود القديم

Sub Transfer2()
Dim ws As Worksheet, Sh As Worksheet
Dim ShName As String
Set ws = Sheets("Main")
ShName = ws.Range("C1").Value
On Error Resume Next
For Each Sh In ThisWorkbook.Worksheets
If Sh.Name <> ShName Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = ShName
Sheets(ShName).DisplayRightToLeft = False
Else
Call TransferToSpecificSheet
Exit Sub
End If
Exit For
Next
ws.Range("A2:F90").Copy
Sheets(ShName).Select
Sheets(ShName).Range("A1").Select
ActiveCell.PasteSpecial xlPasteAll
Selection.Columns.ShrinkToFit = True
Application.CutCopyMode = False
End Sub

أحسنت استاذ ابراهيم بارك الله فيك وزادك الله من فضله-نعم تم المطلوب بعد فضل ربنا على يد حضرتك
ولكن عندى مشكلة عندما تم الترحيل اعطانى خطأ بالعمود E فى الصفحة المرحلة الجديدة وهو عمود Amount ( المبلغ) لأنه كان يحتوى على معادلة بصفحة Main
فقد تم استبدال هذا السطر من الكود

ActiveCell.PasteSpecial xlPasteAll

بهذان السطران

ActiveCell.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
ActiveCell.PasteSpecial Paste:=xlPasteValues

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

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

Sub TransferToSpecificSheet()
    Dim Cell As Range, T As String, LR As Long, LRT As Long
    Dim ws As Worksheet, Sh As Worksheet, Answer As Long
        Set ws = Sheets("Main")
    LR = ws.Cells(1000, 3).End(xlUp).Row
    T = ws.Range("c1").Value
        Application.ScreenUpdating = False
        If Not IsEmpty(ws.Range("c1")) Then
For i = 1 To Worksheets.Count
If Worksheets(i).Name = T Then
  exists = True
  End If
  Next i
  If Not exists Then
  Worksheets.Add(after:=Sheets(Sheets.Count)).Name = T
  ws.Range("A2:F2").Copy
 With Sheets(T)
 .Range("A1").Select
 .Range("A1").PasteSpecial xlPasteFormats
 .Range("A1").PasteSpecial xlPasteValues
  .DisplayRightToLeft = False
 End With
  End If
                
        ws.Range("b3:f" & LR).Copy
        With Sheets(T)
            LRT = .Cells(Rows.Count, 3).End(xlUp).Row + 1
            .Cells(LRT, 2).PasteSpecial xlPasteValues
            .Cells(LRT, 2).PasteSpecial xlPasteFormats
            .Columns("A:F").ShrinkToFit = True
        End With
          Else
          MsgBox "الخلية المحددة فارغة لذا لا يتم تنفيذ الكود": Exit Sub
          Exit Sub
          End If
                              
                Answer = MsgBox("هل تريد ان تمسح البيانات فى ورقة 1 أم لا ؟", vbYesNo + vbQuestion)
                If Answer = vbYes Then
                Sheets("Main").Activate
                Sheets("Main").Range("b3:d1000,f3:f1000").Select
         Else
         End If
                                      
        Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

بارك الله فيك استاذ ابراهيم وجزاك الله خير الثواب
هو بالفعل المطلوب جعله الله فى ميزان حسناتك

جرب هذا الكود

Sub TransferToSpecificSheet()
    Dim Cell As Range, t As String, LR As Long, LRT As Long
    Dim WS As Worksheet, Answer As Long, Bol As Boolean
        Set WS = Sheets("Main")
    LR = WS.Cells(1000, 3).End(xlUp).Row
    t = WS.Range("c1").Value
        Application.ScreenUpdating = False
      If Not IsEmpty(WS.Range("c1")) Then
   
      Bol = Evaluate("=ISREF(" & "'" & WS.Range("c1") & "'!A1)")

  If Not Bol Then
    Sheets.Add(, after:=Sheets(Sheets.Count)).Name = WS.Range("c1")
    WS.Range("A2:f" & LR).Copy
      With ActiveSheet
      .Range("a1").PasteSpecial (xlPasteValuesAndNumberFormats)
      .Range("a1").PasteSpecial (xlPasteColumnWidths)
      .Range("a1").PasteSpecial (xlPasteFormats)
      .DisplayRightToLeft = False
      End With
      WS.Select
     GoTo End_me
  End If
                WS.Range("A3:f" & LR).Copy
                With Sheets(t)
                    LRT = .Cells(Rows.Count, 3).End(xlUp).Row + 1
                      With .Cells(LRT, 1)
                      .PasteSpecial (xlPasteValuesAndNumberFormats)
                      .PasteSpecial (xlPasteColumnWidths)
                      .PasteSpecial (xlPasteFormats)
                      End With
                End With
      Answer = MsgBox("هل تريد ان تمسح البيانات فى ورقة 1 أم لا ؟", vbYesNo + vbQuestion)
                If Answer = vbYes Then
                    Sheets("Main").Activate
                    Sheets("Main").Range("b3:d1000,f3:f1000").Select
                    Selection.ClearContents
                Else: End If
            Else
' MsgBox "الخلية المحددة فارغة لذا لا يتم تنفيذ الكود": Exit Sub
                    End If
End_me:
            Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

الملف مرفق

أحسنت استاذ سليم كود ممتاز وسريع
دائما مبدع بارك الله فيك وزادك الله من فضله
وجزاكم الله جميعا اساتذتى الكرام كل خير