Макрос для выделения ячеек в другом диапазоне

Question

Есть файл, в котором требуется на втором листе в соответствие с колонками и строками выделить ячейку. Позиции на 2 листе могут быть разные, но все только из списка второго листа. Как правильно прописать макрос, пробовал прописать так

Lastrow = ThisWorkbook.Sheets("лист1").Cells(Rows.Count, 1).End(xlUp).Row
Lastcolumn = ThisWorkbook.Sheets("лист1").Cells(4, Columns.Count).End(xlToLeft).Column
x = ThisWorkbook.Sheets("лист2").Cells(2, 1)
Do While y = Lastcolumn
   For Z = 1 To Lastrow
   For y = 1 To Lastcolumn
        If ThisWorkbook.Sheets("лист1").Cells(Z, 1) = x And ThisWorkbook.Sheets("лист1").Cells(Z, y) > 0 And IsNumeric(ThisWorkbook.Sheets("лист1").Cells(Z, y)) Then
        ThisWorkbook.Sheets("лист2").Cells(5, y).Interior.Color = RGB(240, 150, 0)
         y = y + 1
           Exit For
        End If
    Next y
    Next

Но так не работает.

Пример на картинке.

изменять нужно только формат ячеек так там могут тоже быть формулы

P.s. появилось решение но я его не понимаю при переносе на рабочую форму, слишком много но

Sub Main()
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
Dim y As Long
Dim x As Integer
Dim a As Variant

With Sheets("Лист2")
    a = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
    For y = 2 To UBound(a, 1)
        Set d.Item(a(y, 1)) = CreateObject("Scripting.Dictionary")
    Next
End With

With Sheets("Лист1")
    y = .Cells(.Rows.Count, 1).End(xlUp).Row
    x = .Cells(1, .Columns.Count).End(xlToLeft).Column
    a = .Range(.Cells(1, 1), .Cells(y, x))
    Dim v As Variant
    For Each v In d.Keys
        If WorksheetFunction.CountIfs(.Columns(1), v) > 0 Then
            y = WorksheetFunction.Match(v, .Columns(1), 0)
            For x = 2 To UBound(a, 2)
                If Not IsEmpty(a(y, x)) Then
                    d.Item(v).Item(x) = 0
                End If
            Next
        End If
    Next
End With

Dim r As Range
With Sheets("Лист2")
    For y = 1 To d.Count
        For Each v In d.Items()(y - 1).Keys
            If r Is Nothing Then
                Set r = Cells(y + 1, v)
            Else
                Set r = Union(r, Cells(y + 1, v))
            End If
        Next
    Next

    .Cells.Interior.Pattern = xlNone
    If Not r Is Nothing Then
        r.Interior.Color = 65535
    End If
End With

End Sub есть ли возможность прописать код на поиск совпадений только вертикально и горизонтально с выбором именно какой нужен столбец или строка?

Answer 1

Вот пример макроса, который красит твою таблицу:

Sub x()
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = ThisWorkbook.Sheets("Лист1")
Set sh2 = ThisWorkbook.Sheets("Лист2")
Dim tmp1()
' Копируем данные с листа в массив для ускорения обработки '
tmp1 = sh1.UsedRange.Value
tmp2 = sh2.UsedRange.Value
Dim i As Integer, j As Integer, k As Integer
' Перебираем строки листа назначения '
For i = LBound(tmp2) + 1 To UBound(tmp2)
    ' Перебираем исходные данные, ищем строку с тем же продуктом '
    For j = LBound(tmp1) + 1 To UBound(tmp1)
        If tmp1(j, 1) = tmp2(i, 1) Then
            ' Если нашли - запоминаем номер '
            k = j
            Exit For
        End If
    Next j
    ' Сканируем строку исходных данных на предмет наличия значения '
    For j = LBound(tmp1, 2) + 1 To UBound(tmp1, 2)
        If Not IsEmpty(tmp1(k, j)) Then
            ' Если нашли - красим соотв. ячейку '
            sh2.Cells(i, j).Interior.Color = vbYellow
        End If
    Next j
Next i
End Sub

По горизонтали выполняется сравнение в цикле. По вертикали сделано тупое совпадение по индексу, но можно также организовать перебор (добавить ещё один цикл - просто мне лень).

С массивами работать и проще, и, главное, гораздо быстрее, чем с ячейками. И чем пухлее таблица, тем больше разница. Можно ещё ScreenUpdate=False добавить, это дополнительное ускорение.

БЛОГ НА HUSL

Макрос для выделения ячеек в другом диапазоне

Ответы (1 шт):