Копировать с разных листов макросом

[kuklp]

Я дико извиняюсь! Курочил макрос очень уважаемого мною Сергея(SAS888) и совсем не обратил внимания на слово Private(а должен был, старею). Надо так:

Sub Main()
    Dim i As Integer, a()
    Application.ScreenUpdating = False: Cells.ClearContents
     a = Array("Лист1", "Лист2", "Лист4") ' преречисляете листы в нужном Вам порядке
    For i = 0 To UBound(a)
    Sheets(a(i)).UsedRange.Copy Cells(Rows.Count, 1).End(xlUp).Offset(1)
    Next
    Application.ScreenUpdating = true
End Sub

Теперь макрос будет виден по alt+8.
По поводу:"А можно ещё такой макрос. ..." я обязательно помогу Вам. Как только чуток освобожусь... Одно замечание - Вы напрасно обращаетесь к конкретному человеку в своих сообщениях. На форуме полно замечательных людей(Спецов!), готовых Вам помочь. Но когда Ваше обращение направлено к конкретному человеку... Я тоже, обычно прохожу мимо. В этот раз меня просто заинтересовало решение Сергея(SAS888, многому у него учусь).

[Петро1]

О вот это жизнь. Как вы ребята мне помогли.
Ещё последняя просьба. Есть два макроса, как бы их слепить в один?

Первый макрос
Sub Main1()
Dim i As Long, x As Range, sh As Worksheet: Application.ScreenUpdating = False
For Each sh In Sheets
For i = 2 To sh.Cells(Rows.Count, 1).End(xlUp).Row
If sh.Cells(i, 1) <> "" Then
If sh.Cells(i, 1).Font.Color = vbRed Then
If sh.Cells(i + 1, 1).Font.Color = vbRed Then
If x Is Nothing Then Set x = sh.Cells(i, 1) Else Set x = Union(x, sh.Cells(i, 1))
Else
sh.Cells(i, 1).Copy sh.Cells(i, 1).Offset(, 1)
End If: End If: End If: Next
If Not x Is Nothing Then x.EntireRow.Delete
Set x = Nothing
Next
End Sub
А второй

Sub Main()
Dim i As Integer, a()
Application.ScreenUpdating = False: Cells.ClearContents
a = Array("Ëèñò1", "Ëèñò2", "Ëèñò3") ' ïðåðå÷èñëÿåòå ëèñòû â íóæíîì Âàì ïîðÿäêå
For i = 0 To UBound(a)
Sheets(a(i)).UsedRange.Copy Cells(Rows.Count, 1).End(xlUp).Offset(1)
Next
Application.ScreenUpdating = True
End Sub
Т.к. у меня "руки не стоят" не хочу испортить. За ранее благодарен.

[kuklp]

Так вызовите второй из первого:

Sub Main1()
Dim i As Long, x As Range, sh As Worksheet: Application.ScreenUpdating = False
For Each sh In Sheets
For i = 2 To sh.Cells(Rows.Count, 1).End(xlUp).Row
If sh.Cells(i, 1) <> "" Then
If sh.Cells(i, 1).Font.Color = vbRed Then
If sh.Cells(i + 1, 1).Font.Color = vbRed Then
If x Is Nothing Then Set x = sh.Cells(i, 1) Else Set x = Union(x, sh.Cells(i, 1))
Else
sh.Cells(i, 1).Copy sh.Cells(i, 1).Offset(, 1)
End If: End If: End If: Next
If Not x Is Nothing Then x.EntireRow.Delete
Set x = Nothing
Next
call main
End Sub

[Петро1]

Я ж говорю у меня "руки не стоят", а тем более я не разобрался как закинуть макрос нечто в роде в "стандартные".Тоесть я буду код копировать каждый раз для новой книги, а я ето делаю каждый день несколько раз. Потому и прошу слепить 2 в 1, чтоб максимально упростить жизнь. Если можете то подскажите пожалуйста как это сделать.

[kuklp]

Не надо копировать. Включите макрорекордер. В выпадающем списке выберите пункт "в личной книге макросов" как на картинке. нажмите Ок и наберите в ячейке [a1] 23. Выключите рекордер. Теперь у Вас в редакторе ВБА появилось то, что на рис2. Туда скопируйте макрос из приложенного файла. Все. Оттуда его и запускайте.

[Петро1]

Сообщение от kuklp

Не надо копировать. Включите макрорекордер. В выпадающем списке выберите пункт "в личной книге макросов" как на картинке. нажмите Ок и наберите в ячейке [a1] 23. Выключите рекордер. Теперь у Вас в редакторе ВБА появилось то, что на рис2. Туда скопируйте макрос из приложенного файла. Все. Оттуда его и запускайте.

Уважаемые kuklp и SAS888 и другие учасники форума примного вам благодарен. Теперь жить (работать) стало раз 20 легче. Раньше я это всё вручную делал . Всё, теперь разобрался, программы работают отлично. Ещё раз спасибо.

kuklp а мы с вами земляки! Я тоже с Украины.