ترحيل الى عدة شيتات

[raslandream]

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

في الملف المرفق شيت اكسيل يوضح رجائي

يارب حد يعرف

 

 

Data.rar

[شوقي ربيع]

تفضل اخي 

استعمل هذا الكود 

Sub test()
Dim sh As Worksheet
Dim Lr As Long
Dim T As String

For Each sh In ThisWorkbook.Worksheets
T = sh.Name
For i = 1 To 4
Set sh = ThisWorkbook.Sheets("shop" & i)
If T = sh.Name Then
    Lr = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
    
    sh.Range("A" & Lr) = Date
    sh.Range("B" & Lr) = Feuil1.Range("B" & i + 6)
    sh.Range("C" & Lr) = Feuil1.Range("C" & i + 6)
    sh.Range("D" & Lr) = Feuil1.Range("D" & i + 6)
    
End If
Next
Next

For i = 7 To 10
Feuil1.Range("B" & i) = ""
Feuil1.Range("C" & i) = ""
Feuil1.Range("D" & i) = ""
Next

End Sub

وهذا المرفق مطبق عليه الكود

Data.rar

[شوقي ربيع]

وهذا كود ثاني اكثر سرعة واختصار 

Sub test2()
Dim sh As Worksheet
Dim Lr As Long

For i = 1 To 4
Set sh = ThisWorkbook.Sheets("shop" & i)
Lr = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
   
    sh.Range("A" & Lr) = Date
    sh.Range("B" & Lr) = Feuil1.Range("B" & i + 6)
    sh.Range("C" & Lr) = Feuil1.Range("C" & i + 6)
    sh.Range("D" & Lr) = Feuil1.Range("D" & i + 6)
    
    Feuil1.Range("B" & i + 6) = ""
    Feuil1.Range("C" & i + 6) = ""
    Feuil1.Range("D" & i + 6) = ""
    
Next

End Sub