Как в этом макросе указать , что-бы было название каждого листа и книги ,при сборе всех листов на один ?

[Александр 33]

Уважаемые форумчане , подскажите пожалуйста , как в этом макросе
сделать так , что-бы
Перед, каждыми собранными данными с одного листа в начале на строку выше, что-бы было написано название с какого листа эти данные к примеру (Лист 1, и т.д ) , на общем листе ("полный список")

Sub korobka()
Dim Ws As Worksheet
Dim LastRow As Long
Dim iLastRow As Long
Dim Rng As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False
If Sheets(Sheets.Count).Name = "Полный_список" Then Sheets(Sheets.Count).Delete
Sheets(1).Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "Полный_список"
Set Rng = ActiveSheet.UsedRange
Rng.Clear
For i = 1 To Sheets.Count - 1
LastRow = Cells(Rows.Count, 2).End(xlUp).Row
With Sheets(i)
iLastRow = .Cells(Rows.Count, 2).End(xlUp).Row
Range(.Cells(1, 1), .Cells(iLastRow, 3)).Copy Cells(LastRow + 2, 1)
Range(.Cells(1, 6), .Cells(iLastRow, 9)).Copy Cells(LastRow + 2, 5)
End With
Next
Rows(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

[IgorGO]

...
For i = 1 To Sheets.Count - 1
LastRow = Cells(Rows.Count, 2).End(xlUp).Row
cells(lastrow,1) = sheets(i).name
lastrow = lastrow+1
With Sheets(i)
...

[Александр 33]

Большое спасибо IgorGO !!! Это второй сайт , на котором я задал этот вопрос и только вы смогли ответить , так быстро . Настоящий Профессионал !!!

[IgorGO]

Ну раз Вы так...

If Sheets(Sheets.Count).Name = "Полный_список" Then Sheets(Sheets.Count).Delete
Sheets(1).Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "Полный_список"
Set Rng = ActiveSheet.UsedRange
Rng.Clear

этот фрагмент кода вызвал недоумение: зачем удалять "Полный_список" чтобы тут же вставить лист с таким же именем и на то же место? Возможно в этом есть какой-то глубинный смысл, которого я не знаю, но я бы переписал этот кусок так:

If Sheets(Sheets.Count).Name = "Полный_список" Then 
  Sheets(Sheets.Count).activate
else
  Sheets(1).Copy After:=Sheets(Sheets.Count)
  Sheets(Sheets.Count).Name = "Полный_список"
end if
ActiveSheet.UsedRange.Clear

и обьяление Dim Rng As Range можно снести - Rng не используется нигде.

[Александр 33]

IgorGO , всё отлично я сделал , что вы мне подсказали . Только я не знаю , как сделать , что-бы название листа , которое вставляется ,не удаляла нижнюю ячейку со значением , а вставлялась где нибудь на не занятой ячейке ? Прошу Извинений , что раньше это не написал .

[IgorGO]

...
For i = 1 To Sheets.Count - 1
LastRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
cells(lastrow,1) = sheets(i).name
lastrow = lastrow+1
With Sheets(i)
...

[Александр 33]

IgorGO всё Прекрасно получилось с Вашей помощью !!! С меня будет маленькая благодарность , по Webmoney !!!

Вот код :

Sub superkorobka()
Dim Ws As Worksheet
Dim LastRow As Long
Dim iLastRow As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
If Sheets(Sheets.Count).Name = "Полный_список" Then
Sheets(Sheets.Count).Activate
Else
Sheets(1).Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "Полный_список"
End If
ActiveSheet.UsedRange.Clear
For i = 1 To Sheets.Count - 1
LastRow = Cells(Rows.Count, 2).End(xlUp).row + 1
Cells(LastRow, 1) = Sheets(i).Name
LastRow = LastRow + 1
With Sheets(i)
iLastRow = .Cells(Rows.Count, 2).End(xlUp).row
Range(.Cells(1, 1), .Cells(iLastRow, 3)).Copy Cells(LastRow + 2, 1)
Range(.Cells(1, 6), .Cells(iLastRow, 9)).Copy Cells(LastRow + 2, 5)

End With
Next
Rows(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

[IgorGO]

и я рад за Вас!
Александр, обращайтесь.

С Рождеством!!!

[Александр 33]

Большое спасибо и вас поздравляю , с Рождеством !!!

[Александр 33]

Вернее будет , Вас , поздравляю с Рождеством !!!