Копировать макросом по цвету текста

[Петро1]

Здравствуйте ув. форумчане снова. Создаю ещё одну тему т.к. трудно найти похожие примеры. Смысл в чём, нужен такой макрос, чтоб находил ячейку с красным текстом и копировал её содержимое в соседнюю ячейку справа. И при том что в одной книге много разных листов но везде одинаковая задача. Прирепляю пример. Вообщем на листе1 так как есть, а на листе2 так как надо. Подскажите пожалуйста как быть.

[SAS888]

Посмотрите пример во вложении. Сделано для столбца "A" активного листа. Добавьте цикл по требуемым листам и подставьте требуемый диапазон для поиска "красных" значений.
P.S. В Excel 2007 лучше воспользоваться автофильтром по цвету.

[Петро1]

Отлично, спасибо. А на счёт задать цикл для требуемых листов, тут проблемка. Я в програмировании не очень, не подскажите каким образом это можна осуществить?
В принцыпе, мне нужно проделать такую манипуляцию со всеми листами в открытой книге.

[Петро1]

Люди добрые, мой предыдущий пост всё-ещё актуален. Помогите кто чем может

[Hugo121]

Sub Main()
    Dim i As Long, x As Range, y As Range, sh as Object : Application.ScreenUpdating = False
'Задайте требуемый диапазон x для поиска "красных" значений.
'Для примера, зададим столбец "A".
For Each sh In Sheets
    Set x = Intersect(sh.UsedRange, sh.[A:A])
    For Each y In x
        If y <> "" Then If y.Font.Color = vbRed Then y.Copy y.Offset(, 1)
    Next
Next
End Sub

[Петро1]

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

Sub Main()
    Dim i As Long, x As Range, y As Range, sh as Object : Application.ScreenUpdating = False
'Задайте требуемый диапазон x для поиска "красных" значений.
'Для примера, зададим столбец "A".
For Each sh In Sheets
    Set x = Intersect(sh.UsedRange, sh.[A:A])
    For Each y In x
        If y <> "" Then If y.Font.Color = vbRed Then y.Copy y.Offset(, 1)
    Next
Next
End Sub

Отлично, огромное спасибо!

[Петро1]

И все же ещё один вопрос.
В примере понятнее, вообщем есть названия разделов красными буквами под ними описание. Там где разделы пустые (без товара ниже), их нужно удалить. Вообщем принцип такой, макрос находит красными буквами название раздела, если ниже снова название раздела, то первое он удаляет (всю строчку вместе с названием). В общем в примере понятние.

[SAS888]

Например, так:

Sub Main()
    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

Пример во вложении. Откройте файл и запустите макрос "Main".

[Петро1]

SAS888 огромнейшее спасибо, как жить сразу стало легче.