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

Вход

Регистрация

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

 

= Мир MS Excel/Сравнение двух таблиц с выделением различий цветом - Мир MS Excel

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

Коллег, помогите сравнить два листа с таблицами.
Лист S2 - эталон.
Лист S1 - был отредактирован.
Ели были внесены изменения в ячейках - макрос отлично справляется и выделяет цветом строку и ячейку с изменениями.
Но если в таблицу на листе S1 была добавлена новая строка - получается хаус!
Подскажите, как прикрутить вариант, если была добавлена новая строка, чтоб она тоже выделялась?
[vba]
Код

Sub Сравнение()
   Dim i As Long, j As Long, a, b
   Dim t As Date
   Dim Cout_r As Variant
   t = Timer
   a = Sheets("S2").UsedRange
   Application.ScreenUpdating = False
   With Sheets("S1")
      b = .Range(.cells(1), .cells(UBound(a), UBound(a, 2)))
      For i = 1 To UBound(a)
        Cout_r = 1
         For j = 1 To UBound(a, 2)
            If a(i, j) <> b(i, j) Then
                If Cout_r = 1 Then
                    Cout_r = 2
                    .Rows(i).Select
                    With Selection.Interior
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                        .ThemeColor = xlThemeColorAccent2
                        .TintAndShade = 0.599993896298105
                        .PatternTintAndShade = 0
                    End With
                End If
               .cells(i, j).Select
                With Selection.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent5
                .TintAndShade = 0.599993896298105
                .PatternTintAndShade = 0
                End With
            End If
         Next j
      Next i
   End With
   Application.ScreenUpdating = True
   Debug.Print Format(Timer - t, "#0.00")
End Sub
[/vba]
 
Ответить
СообщениеКоллег, помогите сравнить два листа с таблицами.
Лист S2 - эталон.
Лист S1 - был отредактирован.
Ели были внесены изменения в ячейках - макрос отлично справляется и выделяет цветом строку и ячейку с изменениями.
Но если в таблицу на листе S1 была добавлена новая строка - получается хаус!
Подскажите, как прикрутить вариант, если была добавлена новая строка, чтоб она тоже выделялась?
[vba]
Код

Sub Сравнение()
   Dim i As Long, j As Long, a, b
   Dim t As Date
   Dim Cout_r As Variant
   t = Timer
   a = Sheets("S2").UsedRange
   Application.ScreenUpdating = False
   With Sheets("S1")
      b = .Range(.cells(1), .cells(UBound(a), UBound(a, 2)))
      For i = 1 To UBound(a)
        Cout_r = 1
         For j = 1 To UBound(a, 2)
            If a(i, j) <> b(i, j) Then
                If Cout_r = 1 Then
                    Cout_r = 2
                    .Rows(i).Select
                    With Selection.Interior
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                        .ThemeColor = xlThemeColorAccent2
                        .TintAndShade = 0.599993896298105
                        .PatternTintAndShade = 0
                    End With
                End If
               .cells(i, j).Select
                With Selection.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent5
                .TintAndShade = 0.599993896298105
                .PatternTintAndShade = 0
                End With
            End If
         Next j
      Next i
   End With
   Application.ScreenUpdating = True
   Debug.Print Format(Timer - t, "#0.00")
End Sub
[/vba]

Автор - ericcom
Дата добавления - 02.02.2022 в 16:53
Pelena Дата: Среда, 02.02.2022, 21:35 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 18604
Репутация: 4216 ±
Замечаний: ±

Excel 2016 & Mac Excel
Встроенная надстройка Inquire не вариант?


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

Автор - Pelena
Дата добавления - 02.02.2022 в 21:35
ericcom Дата: Четверг, 03.02.2022, 08:20 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Встроенная надстройка Inquire не вариант?


Нет, надстройки не вариант.
 
Ответить
Сообщение
Встроенная надстройка Inquire не вариант?


Нет, надстройки не вариант.

Автор - ericcom
Дата добавления - 03.02.2022 в 08:20
Nic70y Дата: Четверг, 03.02.2022, 08:23 | Сообщение № 4
Группа: Друзья
Ранг: Экселист
Сообщений: 7855
Репутация: 1891 ±
Замечаний: 0% ±

Excel 2010
ericcom, файл-пример-эксель приложите


ЮMoney 41001841029809
 
Ответить
Сообщениеericcom, файл-пример-эксель приложите

Автор - Nic70y
Дата добавления - 03.02.2022 в 08:23
ericcom Дата: Четверг, 03.02.2022, 08:58 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Nic70y, Запуск макроса с листа S1
К сообщению приложен файл: 5806303.xlsm(61.0 Kb)
 
Ответить
СообщениеNic70y, Запуск макроса с листа S1

Автор - ericcom
Дата добавления - 03.02.2022 в 08:58
Nic70y Дата: Четверг, 03.02.2022, 09:47 | Сообщение № 6
Группа: Друзья
Ранг: Экселист
Сообщений: 7855
Репутация: 1891 ±
Замечаний: 0% ±

Excel 2010
[vba]
Код
Sub u_700()
    Application.ScreenUpdating = False
    a = Application.Match("ИТОГО", Range("b:b"), 0) - 1
    For b = 5 To a 'с 5-ой до строки, где ИТОГО (не включая)
        c = Application.Match(Range("b" & b), Sheets("S2").Range("b:b"), 0) '=ПОИСКПОЗ(
        d = Application.IsNumber(c) '=ЕЧИСЛО
        If d Then
            For e = 3 To 34 'с 3-го до 34 столбца
                f = Cells(b, e).Offset(0, -1).Interior.Color
                If Cells(b, e) <> Sheets("S2").Cells(c, e) Then
                    Cells(b, e).Interior.Color = 15652797
                    If f = 16777215 Then Range(Cells(b, 1), Cells(b, e - 1)).Interior.Color = 11389944
                Else
                    If f <> 16777215 Then Cells(b, e).Interior.Color = 11389944
                End If
            Next
        Else
            Range("a" & b & ":ah" & b).Interior.Color = 15652797
        End If
    Next
    Application.ScreenUpdating = False
End Sub
[/vba]
К сообщению приложен файл: 117.xlsm(59.9 Kb)


ЮMoney 41001841029809
 
Ответить
Сообщение[vba]
Код
Sub u_700()
    Application.ScreenUpdating = False
    a = Application.Match("ИТОГО", Range("b:b"), 0) - 1
    For b = 5 To a 'с 5-ой до строки, где ИТОГО (не включая)
        c = Application.Match(Range("b" & b), Sheets("S2").Range("b:b"), 0) '=ПОИСКПОЗ(
        d = Application.IsNumber(c) '=ЕЧИСЛО
        If d Then
            For e = 3 To 34 'с 3-го до 34 столбца
                f = Cells(b, e).Offset(0, -1).Interior.Color
                If Cells(b, e) <> Sheets("S2").Cells(c, e) Then
                    Cells(b, e).Interior.Color = 15652797
                    If f = 16777215 Then Range(Cells(b, 1), Cells(b, e - 1)).Interior.Color = 11389944
                Else
                    If f <> 16777215 Then Cells(b, e).Interior.Color = 11389944
                End If
            Next
        Else
            Range("a" & b & ":ah" & b).Interior.Color = 15652797
        End If
    Next
    Application.ScreenUpdating = False
End Sub
[/vba]

Автор - Nic70y
Дата добавления - 03.02.2022 в 09:47
ericcom Дата: Четверг, 03.02.2022, 13:27 | Сообщение № 7
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Nic70y, Классное решение!
Спасибо за помощь!
 
Ответить
СообщениеNic70y, Классное решение!
Спасибо за помощь!

Автор - ericcom
Дата добавления - 03.02.2022 в 13:27
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сравнение двух таблиц с выделением различий цветом (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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