Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Макрос сравнение ячеек и окраска в цвет красный зеленый - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос сравнение ячеек и окраска в цвет красный зеленый (Макросы/Sub)
Макрос сравнение ячеек и окраска в цвет красный зеленый
ZAV Дата: Понедельник, 13.04.2020, 16:49 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 10
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Есть макрос впринципе рабочий но...
Описание:
В книге есть 2 листа
1 Лист, столбец А постоянно в ношу информацию (точнее вставляю из другого источника методом копирования), информация в столбик и хаотично, может повторятся.
2 Лист, столбец А постоянная база данных которая периодически пополняется или частично удаляется в ручную, после каждого внесения фильтрую столбик по А-Я.
Суть макроса:
Сравнить Лист 1 столбец А с Листом 2 столбец А, если есть совпадение то в 1 Листе столбец В проставляется порядковый номер строки (он указан в 2 Лист столбец В).

Помогите добавить действие в макрос и исправить постоянную проблему, а именно.

Добавить действие:
Если есть совпадения с базой (2 Лист) то ячейку окрасить в зеленый цвет (vbGreen), если совпадений нет то естественно красный (vbRed)

Исправить:
В 1 Лист столбец А вставляю (методом копирования) нужную информация и так бывает что значение имеет лишние пробелы соответственно сходства уже нет с базой.

Сам макрос:

[vba]
Код
Sub База()
iLastRow = Worksheets(1).Cells(Worksheets(1).Rows.Count, "A").End(xlUp).Row
iLastRow2 = Worksheets(2).Cells(Worksheets(2).Rows.Count, "A").End(xlUp).Row
For i = 2 To iLastRow
For i2 = 2 To iLastRow2
If Worksheets(2).Range("A" & i2).Value = Worksheets(1).Range("A" & i).Value Then
Worksheets(2).Range("B" & i2).Copy Destination:=Worksheets(1).Range("B" & i)
End If
Next
Next
End Sub
[/vba]

не уверен что он работает без конфликтов, так как после проработки макроса есть небольшое залипание (в таблице можно видеть две выделены ячейки)
СПС...
К сообщению приложен файл: 7856862.xlsm(21.9 Kb)


На работу надо ходить работать, а не для отметки в явочном листе!!!

Сообщение отредактировал ZAV - Понедельник, 13.04.2020, 17:27
 
Ответить
СообщениеЕсть макрос впринципе рабочий но...
Описание:
В книге есть 2 листа
1 Лист, столбец А постоянно в ношу информацию (точнее вставляю из другого источника методом копирования), информация в столбик и хаотично, может повторятся.
2 Лист, столбец А постоянная база данных которая периодически пополняется или частично удаляется в ручную, после каждого внесения фильтрую столбик по А-Я.
Суть макроса:
Сравнить Лист 1 столбец А с Листом 2 столбец А, если есть совпадение то в 1 Листе столбец В проставляется порядковый номер строки (он указан в 2 Лист столбец В).

Помогите добавить действие в макрос и исправить постоянную проблему, а именно.

Добавить действие:
Если есть совпадения с базой (2 Лист) то ячейку окрасить в зеленый цвет (vbGreen), если совпадений нет то естественно красный (vbRed)

Исправить:
В 1 Лист столбец А вставляю (методом копирования) нужную информация и так бывает что значение имеет лишние пробелы соответственно сходства уже нет с базой.

Сам макрос:

[vba]
Код
Sub База()
iLastRow = Worksheets(1).Cells(Worksheets(1).Rows.Count, "A").End(xlUp).Row
iLastRow2 = Worksheets(2).Cells(Worksheets(2).Rows.Count, "A").End(xlUp).Row
For i = 2 To iLastRow
For i2 = 2 To iLastRow2
If Worksheets(2).Range("A" & i2).Value = Worksheets(1).Range("A" & i).Value Then
Worksheets(2).Range("B" & i2).Copy Destination:=Worksheets(1).Range("B" & i)
End If
Next
Next
End Sub
[/vba]

не уверен что он работает без конфликтов, так как после проработки макроса есть небольшое залипание (в таблице можно видеть две выделены ячейки)
СПС...

Автор - ZAV
Дата добавления - 13.04.2020 в 16:49
Pelena Дата: Понедельник, 13.04.2020, 17:19 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 18606
Репутация: 4219 ±
Замечаний: ±

Excel 2016 & Mac Excel
в таблице можно видеть
таблица не приложилась


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
Сообщение
в таблице можно видеть
таблица не приложилась

Автор - Pelena
Дата добавления - 13.04.2020 в 17:19
ZAV Дата: Понедельник, 13.04.2020, 17:32 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 10
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Приложил


На работу надо ходить работать, а не для отметки в явочном листе!!!
 
Ответить
СообщениеПриложил

Автор - ZAV
Дата добавления - 13.04.2020 в 17:32
_Boroda_ Дата: Понедельник, 13.04.2020, 18:28 | Сообщение № 4
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16496
Репутация: 6420 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Макрос в модуле листаЛист1
[vba]
Код
Sub Prover()
    Application.ScreenUpdating = 0 'откл обновление экрана
    Application.Calculation = 3 'откл автопересчет формул
    n1_ = Cells(Rows.Count, "A").End(3).Row - 1 'кол-во строк на этом листе (Лист1), начиная со второй
    ar1 = Cells(2, 1).Resize(n1_).Value 'суем столбец А в массив
    ReDim ar2(1 To n1_, 1 To 1) 'создаем пустой массив
    Cells(2, 1).Resize(n1_).Interior.Color = 10092441 'красим все в зеленый
    With Sheets("База") 'для листа База
        n11_ = .Cells(.Rows.Count, "A").End(3).Row - 1 'кол-во строк, начиная со второй
        ar11 = .Cells(2, 1).Resize(n11_, 2).Value 'суем столбцы А:В в массив
    End With '
    Set slov = CreateObject("Scripting.Dictionary") 'объявляем словарь
    With slov 'для словаря
        .CompareMode = 1 'текстовое сравнение (бол и мал буквы не различаются)
        For i = 1 To UBound(ar11) 'цикл по массиву ar11
            .Item(Replace(ar11(i, 1), " ", "")) = ar11(i, 2) 'первый столбец (без пробелов) - ключ, второй - элемент словаря
        Next i
        For i = 1 To UBound(ar1) 'цикл по массиву ar1
            z_ = Replace(ar1(i, 1), " ", "") 'убираем пробелы
            If .Exists(z_) Then 'если полученное есть в словаре
                ar2(i, 1) = .Item(z_) 'в массив ar2 суем элемент для искомого ключа
            Else 'если нет в словаре
                Cells(i + 1, 1).Interior.Color = 5263615 'красим красным
            End If '
        Next i '
    End With '
    Cells(2, 2).Resize(n1_) = ar2 'в столбец 2 этого листа суем массив ar2
    Application.Calculation = 1 'вкл автопересчет формул
    Application.ScreenUpdating = 1 'вкл обновление экрана
End Sub
[/vba]
К сообщению приложен файл: 7856862_1.xlsm(24.4 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеМакрос в модуле листаЛист1
[vba]
Код
Sub Prover()
    Application.ScreenUpdating = 0 'откл обновление экрана
    Application.Calculation = 3 'откл автопересчет формул
    n1_ = Cells(Rows.Count, "A").End(3).Row - 1 'кол-во строк на этом листе (Лист1), начиная со второй
    ar1 = Cells(2, 1).Resize(n1_).Value 'суем столбец А в массив
    ReDim ar2(1 To n1_, 1 To 1) 'создаем пустой массив
    Cells(2, 1).Resize(n1_).Interior.Color = 10092441 'красим все в зеленый
    With Sheets("База") 'для листа База
        n11_ = .Cells(.Rows.Count, "A").End(3).Row - 1 'кол-во строк, начиная со второй
        ar11 = .Cells(2, 1).Resize(n11_, 2).Value 'суем столбцы А:В в массив
    End With '
    Set slov = CreateObject("Scripting.Dictionary") 'объявляем словарь
    With slov 'для словаря
        .CompareMode = 1 'текстовое сравнение (бол и мал буквы не различаются)
        For i = 1 To UBound(ar11) 'цикл по массиву ar11
            .Item(Replace(ar11(i, 1), " ", "")) = ar11(i, 2) 'первый столбец (без пробелов) - ключ, второй - элемент словаря
        Next i
        For i = 1 To UBound(ar1) 'цикл по массиву ar1
            z_ = Replace(ar1(i, 1), " ", "") 'убираем пробелы
            If .Exists(z_) Then 'если полученное есть в словаре
                ar2(i, 1) = .Item(z_) 'в массив ar2 суем элемент для искомого ключа
            Else 'если нет в словаре
                Cells(i + 1, 1).Interior.Color = 5263615 'красим красным
            End If '
        Next i '
    End With '
    Cells(2, 2).Resize(n1_) = ar2 'в столбец 2 этого листа суем массив ar2
    Application.Calculation = 1 'вкл автопересчет формул
    Application.ScreenUpdating = 1 'вкл обновление экрана
End Sub
[/vba]

Автор - _Boroda_
Дата добавления - 13.04.2020 в 18:28
ZAV Дата: Понедельник, 13.04.2020, 22:03 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 10
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
ОГРОМНОЕ СПАСИБО!!!


На работу надо ходить работать, а не для отметки в явочном листе!!!
 
Ответить
СообщениеОГРОМНОЕ СПАСИБО!!!

Автор - ZAV
Дата добавления - 13.04.2020 в 22:03
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос сравнение ячеек и окраска в цвет красный зеленый (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2022 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!