Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос для выделения ячеек в другом диапазоне
 
#1
20.02.2020 16:53:58
Добрый день! Есть файл, в котором требуется на втором листе в соответствие с колонками и строками выделить ячейку. Как правильно прописать макрос, пробовал прописать так
Код
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
Но так не работает.
Пример в файле.
 
 
 
#2
20.02.2020 17:21:27
Код
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
 
 
 
#3
20.02.2020 17:27:43
МатросНаЗебре, Огромное спасибо!!! буду разбираться как все работает
 
 
 
#4
20.02.2020 23:53:56
Создали- имейте уважение, отвечайте в своих темах...
 
 
 
#5
28.02.2020 12:04:10
МатросНаЗебре Здравствуйте, подскажите можно ли еще как то доработать код, так как scripting.dictionary и некоторые строчки кода мне не понятны(11,23-25...) до сих пор хоть и сидел читал про них. Есть ли возможность прописать код на поиск совпадений вертикально и горизонтально с выбором именно - какой нужен столбец или строка?В какой то момент он мне закрасил все что не нужно так как столбцы таблицы начинаются не с первой строки на втором листе
 
 
 
#6
28.02.2020 12:06:20
Цитата
vikttur написал:
Создали - имейте уважение, отвечайте в своих темах...
прошу прощения по работе не успеваю ответить, из-за специфики организации работы остается не так много времени на вба
Изменено: Sapfuldog1 - 28.02.2020 12:06:45
 
 
 
#7
28.02.2020 12:10:33
Цитата
Sapfuldog1 написал:
прошу прощения по работе не успеваю ответить, из-за специфики организации работы остается не так много времени на вба
А причём тут VBA? Это ведь элементарная вежливость, - ответить тем, кто Вам помог.
И интересно получается: ответить нет времени, а на создание новой темы время находится.
 
 
 
#8
28.02.2020 12:14:32
Если вы в разъездах то это сложно сделать не находясь перед компьютером. Виноват, если это приносит неудобства.
 
 
 
#9
28.02.2020 12:31:09
А причём тут "отмазка" про VBA?
Нашли время для создания новой темы - найдите время и для ответов тем, кто потратил своё время на помощь Вам. Иначе Вам просто перестанут помогать.
 
 
 
#10
28.02.2020 15:16:06
Код
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
вот еще одно интересное решение постараюсь понять так как не хватает перебора на наличие соответствий по признаку по вертикали и горизонтали
 
 
 
#11
28.02.2020 16:11:40
Код
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")
        Dim xTovar As Integer
        Dim yTovar As Long
        For x = .UsedRange.Column To .UsedRange.Column + .UsedRange.Columns.Count - 1
            If WorksheetFunction.CountIfs(.Columns(x), "Товар") > 0 Then
                xTovar = x
                Exit For
            End If
        Next
        For y = .UsedRange.Row To .UsedRange.Row + .UsedRange.Rows.Count - 1
            If WorksheetFunction.CountIfs(.Rows(y), "Товар") > 0 Then
                yTovar = y
                Exit For
            End If
        Next
        
        If xTovar > 0 And yTovar > 0 Then
            y = .Cells(.Rows.Count, xTovar).End(xlUp).Row
            x = .Cells(yTovar, .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(xTovar), v) > 0 Then
                    y = WorksheetFunction.Match(v, .Columns(xTovar), 0)
                    For x = xTovar + 1 To UBound(a, 2)
                        If Not IsEmpty(a(y, x)) Then
                            d.Item(v).Item(x - xTovar + 1) = 0
                        End If
                    Next
                End If
            Next
        End If
    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
Так можно перемещать таблицу на Листе 1. Будет искать левый верхний угол по строке "Товар".
 
 
 
#12
02.03.2020 11:50:39
Голову сломал пытаюсь понять, как физически представить структуру записывания через dictionary. Проблема в том, что при смещениях и в случае нулей в первой таблице макрос перестает работать.  
 
 
 
#13
02.03.2020 12:24:40
МатросНаЗебре подскажите, как регулировать область данных и менять условие закрашивания. Я так понял, что 62-64 строка отвечает за закрашивание, но что делать если в таблице есть 0 вместо nothing?
 
 
 
Страницы: 1
Наверх