السلام عليكم
لاثراء الموضوع يمكن استعمال هذا الكود
Sub sCopy()
Dim i As Long, r As Long, Lrr As Long, M As Integer
Dim S
Application.ScreenUpdating = False
Lrr = Sheets("1").Cells(Rows.Count, "A").End(xlUp).Row
For r = 2 To Lrr
For Each S In ThisWorkbook.Sheets
M = S.Cells(Rows.Count, "A").End(xlUp).Row + 1
If Left(Sheets("1").Cells(r, 1), 3) = S.Name Then
Sheets("1").Range("A" & r).Copy
With S
.Range("A" & M).PasteSpecial xlPasteValues
Application.CutCopyMode = False
M = M + 1: End With
End If
Next
Next
End Sub