السلام عليكم
جرب هذا الكود
Sub sheet_collec()
x = Worksheets.Count
Worksheets(2).Select
For i = 2 To x
Worksheets(i).Select
Range("A2", ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
rr = Selection.Rows.Count
sh = Worksheets(i).Name
Range("A2").Select
Worksheets(1).Select
ActiveCell.SpecialCells(xlLastCell).Select
ActiveCell.Offset(1, 0).Select
Selection.End(xlToLeft).Select
ActiveSheet.Paste
For j = 1 To rr
ActiveCell.Offset(j - 1, 3).Value = sh
Next j
Next i
End Sub
كما بالمرفق
يحتاج تعديل بسيط أستأذن أحد الأخوة لتحسينه
حيث أنني غير متمكن في الأكواد
تحياتي
______________________2.rar