[РЕШЕНО][VB] Поиск значений по цвету и содержанию

[Тем:)ч]

Добрый день, помогите решить вопрос в следующем.
Есть таблица, не изменяющая размеры, но постоянно изменяющая содержание. Помогите настроить так чтобы на другом листе, этого же файла, из основной таблицы, система автоматически копировала не только те ячейки которые имеют знание "R", с заливкой 3(красный), но и соседнюю слева.
Файл во вложение, всю голову уже сломал.

[Aleksandr H.]

перебирай ячейки

Option Explicit
Sub CopyTxt()
    Dim r As Range
    Dim rC, cC, i, j
    Dim nR As Integer
    Set r = UsedRange
    rC = r.Rows.Count
    cC = r.Columns.Count
    Sheets("Лист2").Cells.Clear
    
    nR = 1
    With Sheets("Загородная жизнь")
    For i = 2 To rC
        For j = 1 To cC
            If Right(Trim(LCase(.Cells(i, j))), 1) = "r" Then
            If .Cells(i, j).Interior.ColorIndex = 3 Then
                Sheets("Лист2").Cells(nR, "B") = .Cells(i, j)
                Sheets("Лист2").Cells(nR, "A") = .Cells(i, j - 1)
                nR = nR + 1
            End If
            End If
    Next j, i
    End With
End Sub

[Тем:)ч]

Спасибо но ругается на вот эту строку

Set r = UsedRange

[Aleksandr H.]

А так?

Option Explicit
Sub CopyTxt()
    Dim r As Range
    Dim rC, cC, i, j
    Dim nR As Integer
    Sheets("Лист2").Cells.Clear
    
    nR = 1
    With Sheets("Загородная жизнь")
    Set r = .UsedRange
    rC = r.Rows.Count
    cC = r.Columns.Count
    For i = 2 To rC
        For j = 1 To cC
            If Right(Trim(LCase(.Cells(i, j))), 1) = "r" Then
            If .Cells(i, j).Interior.ColorIndex = 3 Then
                Sheets("Лист2").Cells(nR, "B") = .Cells(i, j)
                Sheets("Лист2").Cells(nR, "A") = .Cells(i, j - 1)
                nR = nR + 1
            End If
            End If
    Next j, i
    End With
End Sub

[Тем:)ч]

то же ругается, ошибка 424

[Aleksandr H.]

Файл с ошибкой где?

[Тем:)ч]

вот, единственное я меняю там вместо лист2, переписываю лист1.

[Serge_Bliznykov]

если заменить код на код из пост #4, ошибок нет:

Option Explicit
Sub CopyTxt()
    Dim r As Range
    Dim rC, cC, i, j
    Dim nR As Integer
    Sheets("Лист1").Cells.Clear
    
    nR = 1
    With Sheets("Загородная жизнь")
    Set r = .UsedRange
    rC = r.Rows.Count
    cC = r.Columns.Count
    For i = 2 To rC
        For j = 1 To cC
            If Right(Trim(LCase(.Cells(i, j))), 1) = "r" Then
            If .Cells(i, j).Interior.ColorIndex = 3 Then
                Sheets("Лист1").Cells(nR, "B") = .Cells(i, j)
                Sheets("Лист1").Cells(nR, "A") = .Cells(i, j - 1)
                nR = nR + 1
            End If
            End If
    Next j, i
    End With
End Sub

p.s.
а Вы реально не видите разницы в

     Set r = UsedRange

и

Set r = .UsedRange

[Тем:)ч]

Спасибо большое работает. Жаль, что нельзя лист запаролить с результатом, чтобы ни кто не влез. Все ок