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

Вход

Регистрация

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

 

= Мир MS Excel/Сравнение двух диапазонов с подсветкой отличий - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сравнение двух диапазонов с подсветкой отличий (Макросы/Sub)
Сравнение двух диапазонов с подсветкой отличий
w00t Дата: Вторник, 07.06.2016, 20:42 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 131
Репутация: 3 ±
Замечаний: 0% ±

Подскажите, пожалуйста, если у кого желание будет. Иногда что-то кропаю (правда долго), а иногда голова не варит, особенно когда понимаешь, что формулами не вариант, а посчитать отличия хочется.

1. [vba]
Код
Range(E6:G)
[/vba] и до последней залитой любым цветом строки (заливка непрерывная) - исходные заполненные данные
2. [vba]
Код
Range(L6:N)
[/vba] и до последней залитой любым цветом строки (заливка непрерывная) - данные, основанные на вышеуказанном диапазоне с внесенными правками
3. Есть непрерывный столбец D (с D6 и по конец последних данных) - на основании него заливается цветом вся таблица. То есть можно ориентироваться на один столбец D, определяя нижнюю границу двух диапазонов, либо на условие - что два диапазона, старый и новый - имеют непрерывную заливку по последнюю строку.
4. Если в диапазоне пункта 2 имеет отличие от соответствующей ячейки диапазона пункта 1 - то выделить ее каким-нибудь цветом.

В целом все так в оригинальной табличке, только данные другие и она большая. Я потом по вот этим отличиям фильтрую по цвету, наглядно видно.
К сообщению приложен файл: 1606197.xlsm (12.9 Kb)
 
Ответить
СообщениеПодскажите, пожалуйста, если у кого желание будет. Иногда что-то кропаю (правда долго), а иногда голова не варит, особенно когда понимаешь, что формулами не вариант, а посчитать отличия хочется.

1. [vba]
Код
Range(E6:G)
[/vba] и до последней залитой любым цветом строки (заливка непрерывная) - исходные заполненные данные
2. [vba]
Код
Range(L6:N)
[/vba] и до последней залитой любым цветом строки (заливка непрерывная) - данные, основанные на вышеуказанном диапазоне с внесенными правками
3. Есть непрерывный столбец D (с D6 и по конец последних данных) - на основании него заливается цветом вся таблица. То есть можно ориентироваться на один столбец D, определяя нижнюю границу двух диапазонов, либо на условие - что два диапазона, старый и новый - имеют непрерывную заливку по последнюю строку.
4. Если в диапазоне пункта 2 имеет отличие от соответствующей ячейки диапазона пункта 1 - то выделить ее каким-нибудь цветом.

В целом все так в оригинальной табличке, только данные другие и она большая. Я потом по вот этим отличиям фильтрую по цвету, наглядно видно.

Автор - w00t
Дата добавления - 07.06.2016 в 20:42
_Boroda_ Дата: Вторник, 07.06.2016, 20:51 | Сообщение № 2
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
формулами не вариант,

А Условным форматированием?
Формула
Код
=($D6<>"")*(L6<>E6)

В файле сделано на 99 строк
Сейчас еще добавлю с динамическим диапазоном. Пару минут подождите
Хотя не, не нужно здесь динамическими диапазонами, это я торможу. Здесь нужно умную таблицу создать, чтобы УФ само размножалось - файл _2
К сообщению приложен файл: 1606197_1.xlsm (13.2 Kb) · 1606197_2.xlsm (14.2 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
Сообщение
формулами не вариант,

А Условным форматированием?
Формула
Код
=($D6<>"")*(L6<>E6)

В файле сделано на 99 строк
Сейчас еще добавлю с динамическим диапазоном. Пару минут подождите
Хотя не, не нужно здесь динамическими диапазонами, это я торможу. Здесь нужно умную таблицу создать, чтобы УФ само размножалось - файл _2

Автор - _Boroda_
Дата добавления - 07.06.2016 в 20:51
w00t Дата: Вторник, 07.06.2016, 21:55 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 131
Репутация: 3 ±
Замечаний: 0% ±

Да, то, спасибо. Только с умной таблицей немного сложнее, потому что таблица, которая подгружается в эксель - это рекордсет (ADODB) акцесса 500k строк*55 столбиков и с ней потом еще некоторые манипуляции выполняются (знаю - жесть, но так пока годится и вроде даже нормально шевелится). Не вполне желательно его преобразовывать в такую табличку.

Хотя вопрос на самом деле - что быстрее на таком диапазоне будет и что лучше. С одной стороны - умная таблица - хорошо, но на реальную таблицу пока опасаюсь - вполне может что-то другое поломаться. Если руки дойдут когда-либо, попробую может в готовые выложить.

PS: Да, попробовал умную табличку, правда программно ее активировать, что-то вроде

[vba]
Код
Sub TestSmartTable()
    ActiveSheet.ListObjects.Add(xlSrcRange, Range("B5").CurrentRegion, , xlYes).Name = "Table2"
End Sub
[/vba]

Но, непонятно как ее просто включить, чтобы никакого форматирования небыло вообще. То есть никаких стилей не применилось, никаких итогов, никаких чередований столбцов. И все-таки в моем случае умные таблицы - небольшое зло, как раз именно потому что автозаполнение и прочие фишки, которые нужно избежать.


Сообщение отредактировал w00t - Вторник, 07.06.2016, 22:47
 
Ответить
СообщениеДа, то, спасибо. Только с умной таблицей немного сложнее, потому что таблица, которая подгружается в эксель - это рекордсет (ADODB) акцесса 500k строк*55 столбиков и с ней потом еще некоторые манипуляции выполняются (знаю - жесть, но так пока годится и вроде даже нормально шевелится). Не вполне желательно его преобразовывать в такую табличку.

Хотя вопрос на самом деле - что быстрее на таком диапазоне будет и что лучше. С одной стороны - умная таблица - хорошо, но на реальную таблицу пока опасаюсь - вполне может что-то другое поломаться. Если руки дойдут когда-либо, попробую может в готовые выложить.

PS: Да, попробовал умную табличку, правда программно ее активировать, что-то вроде

[vba]
Код
Sub TestSmartTable()
    ActiveSheet.ListObjects.Add(xlSrcRange, Range("B5").CurrentRegion, , xlYes).Name = "Table2"
End Sub
[/vba]

Но, непонятно как ее просто включить, чтобы никакого форматирования небыло вообще. То есть никаких стилей не применилось, никаких итогов, никаких чередований столбцов. И все-таки в моем случае умные таблицы - небольшое зло, как раз именно потому что автозаполнение и прочие фишки, которые нужно избежать.

Автор - w00t
Дата добавления - 07.06.2016 в 21:55
w00t Дата: Вторник, 07.06.2016, 23:04 | Сообщение № 4
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 131
Репутация: 3 ±
Замечаний: 0% ±

Нашел любопытный участок кода. Но поправить сложновато на мой случай. Очень похоже, разве что диапазоны у меня динамические, нужно найти границы и потом залить несовпавших.
К сообщению приложен файл: post_188282.zip (52.7 Kb)
 
Ответить
СообщениеНашел любопытный участок кода. Но поправить сложновато на мой случай. Очень похоже, разве что диапазоны у меня динамические, нужно найти границы и потом залить несовпавших.

Автор - w00t
Дата добавления - 07.06.2016 в 23:04
w00t Дата: Среда, 08.06.2016, 09:02 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 131
Репутация: 3 ±
Замечаний: 0% ±

Как вариант (потому что с условным форматированием и умной таблицей совсем никак в моем случае)

В модуле

[vba]
Код
Option Explicit

Public Sub CheckRange()
Dim cell    As Range
Dim xRow    As Long
Dim lstRow  As Long
lstRow = WorksheetFunction.Max(6, Range("B" & Rows.Count).End(xlUp).Row)
For Each cell In Range("L6:N" & lstRow)
    cell.Interior.Color = RGB(146, 208, 80)
    If Cells(cell.Row, "D") <> "" Then
        Select Case cell.Column
        Case Is = 12    '*  L
            If Cells(cell.Row, "L") <> Cells(cell.Row, "E") Then cell.Interior.Color = RGB(255, 102, 204)
        Case Is = 13    '*  M
            If Cells(cell.Row, "M") <> Cells(cell.Row, "F") Then cell.Interior.Color = RGB(255, 102, 204)
        Case Is = 14    '*  N
            If Cells(cell.Row, "N") <> Cells(cell.Row, "G") Then cell.Interior.Color = RGB(255, 102, 204)
        End Select
    End If
Next cell
End Sub
[/vba]

и в листе

[vba]
Код
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
CheckRange
End Sub
[/vba]
К сообщению приложен файл: Test2.xlsm (21.0 Kb)
 
Ответить
СообщениеКак вариант (потому что с условным форматированием и умной таблицей совсем никак в моем случае)

В модуле

[vba]
Код
Option Explicit

Public Sub CheckRange()
Dim cell    As Range
Dim xRow    As Long
Dim lstRow  As Long
lstRow = WorksheetFunction.Max(6, Range("B" & Rows.Count).End(xlUp).Row)
For Each cell In Range("L6:N" & lstRow)
    cell.Interior.Color = RGB(146, 208, 80)
    If Cells(cell.Row, "D") <> "" Then
        Select Case cell.Column
        Case Is = 12    '*  L
            If Cells(cell.Row, "L") <> Cells(cell.Row, "E") Then cell.Interior.Color = RGB(255, 102, 204)
        Case Is = 13    '*  M
            If Cells(cell.Row, "M") <> Cells(cell.Row, "F") Then cell.Interior.Color = RGB(255, 102, 204)
        Case Is = 14    '*  N
            If Cells(cell.Row, "N") <> Cells(cell.Row, "G") Then cell.Interior.Color = RGB(255, 102, 204)
        End Select
    End If
Next cell
End Sub
[/vba]

и в листе

[vba]
Код
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
CheckRange
End Sub
[/vba]

Автор - w00t
Дата добавления - 08.06.2016 в 09:02
nilem Дата: Среда, 08.06.2016, 10:15 | Сообщение № 6
Группа: Авторы
Ранг: Старожил
Сообщений: 1613
Репутация: 563 ±
Замечаний: 0% ±

Excel 2013, 2016
Павел, привет
попробуйте вот так
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("Таблица1[[new Data1]:[new Data4]]")) Is Nothing Then Exit Sub
Target.Interior.ColorIndex = IIf(Target.Value = Target(1, -6).Value, 43, 7)
End Sub
[/vba]


Яндекс.Деньги 4100159601573
 
Ответить
СообщениеПавел, привет
попробуйте вот так
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("Таблица1[[new Data1]:[new Data4]]")) Is Nothing Then Exit Sub
Target.Interior.ColorIndex = IIf(Target.Value = Target(1, -6).Value, 43, 7)
End Sub
[/vba]

Автор - nilem
Дата добавления - 08.06.2016 в 10:15
_Boroda_ Дата: Среда, 08.06.2016, 11:15 | Сообщение № 7
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
А у меня вот такой вариант.
Красит при изменении любого количества ячеек в диапазонах столбцов EFGLMN строк с 6 по последнюю заполненную в столбце D
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim dd_ As Range, d_ As Range
    r1_ = Range("D" & Rows.Count).End(xlUp).Row
    If r1_ < 6 Then Exit Sub
    Set dd_ = Intersect(Target, Range("E6:G" & r1_ & ":L6:L" & r1_))
    If Not dd_ Is Nothing Then
        Application.ScreenUpdating = 0
        tsv0_ = RGB(146, 208, 80)
        tsv1_ = RGB(255, 102, 204)
        sm_ = 7
        For Each d_ In dd_
            of_ = sm_ + 2 * sm_ * (d_.Column > 11)
            ofkr_ = -of_ * (of_ > 0)
            d_.Offset(, ofkr_).Interior.Color = tsv0_
            If d_ <> d_.Offset(, of_) Then
                d_.Offset(, ofkr_).Interior.Color = tsv1_
            End If
        Next d_
    End If
End Sub
[/vba]
К сообщению приложен файл: Test2_3.xlsm (18.8 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеА у меня вот такой вариант.
Красит при изменении любого количества ячеек в диапазонах столбцов EFGLMN строк с 6 по последнюю заполненную в столбце D
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim dd_ As Range, d_ As Range
    r1_ = Range("D" & Rows.Count).End(xlUp).Row
    If r1_ < 6 Then Exit Sub
    Set dd_ = Intersect(Target, Range("E6:G" & r1_ & ":L6:L" & r1_))
    If Not dd_ Is Nothing Then
        Application.ScreenUpdating = 0
        tsv0_ = RGB(146, 208, 80)
        tsv1_ = RGB(255, 102, 204)
        sm_ = 7
        For Each d_ In dd_
            of_ = sm_ + 2 * sm_ * (d_.Column > 11)
            ofkr_ = -of_ * (of_ > 0)
            d_.Offset(, ofkr_).Interior.Color = tsv0_
            If d_ <> d_.Offset(, of_) Then
                d_.Offset(, ofkr_).Interior.Color = tsv1_
            End If
        Next d_
    End If
End Sub
[/vba]

Автор - _Boroda_
Дата добавления - 08.06.2016 в 11:15
w00t Дата: Среда, 08.06.2016, 13:16 | Сообщение № 8
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 131
Репутация: 3 ±
Замечаний: 0% ±

Спасибо! Не разобрался с парой фишек только, сорри что достал)

Если в столбцах с 7 по 11 (которые между нужными) что-то поменять - то закрашивается все с 15 столбца, за пределами таблицы.
ковырял, но пока не вышло отключить закраску, если изменения за пределами EFGLMN (5,6,7,12,13,14 столбцов).

По идее так: [vba]
Код
If d_.Column > 7 And d_.Column < 11 Then Exit Sub
[/vba] перед [vba]
Код
ofkr_ = -of_ * (of_ > 0)
[/vba]

И EFG обычно не меняются. Меняются только LMN.

>Если в L набрать отличное от E значение - то все ок. А если изменить в M или N - то не срабатывает
Эту часть пофиксил [vba]
Код
Set dd_ = Intersect(Target, Range("E6:G" & r1_ & ":L6:N" & r1_))
[/vba]


Сообщение отредактировал w00t - Среда, 08.06.2016, 13:42
 
Ответить
СообщениеСпасибо! Не разобрался с парой фишек только, сорри что достал)

Если в столбцах с 7 по 11 (которые между нужными) что-то поменять - то закрашивается все с 15 столбца, за пределами таблицы.
ковырял, но пока не вышло отключить закраску, если изменения за пределами EFGLMN (5,6,7,12,13,14 столбцов).

По идее так: [vba]
Код
If d_.Column > 7 And d_.Column < 11 Then Exit Sub
[/vba] перед [vba]
Код
ofkr_ = -of_ * (of_ > 0)
[/vba]

И EFG обычно не меняются. Меняются только LMN.

>Если в L набрать отличное от E значение - то все ок. А если изменить в M или N - то не срабатывает
Эту часть пофиксил [vba]
Код
Set dd_ = Intersect(Target, Range("E6:G" & r1_ & ":L6:N" & r1_))
[/vba]

Автор - w00t
Дата добавления - 08.06.2016 в 13:16
_Boroda_ Дата: Среда, 08.06.2016, 13:40 | Сообщение № 9
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Это я неверно dd_ написал. Вот так нужно
[vba]
Код
    Set dd_ = Intersect(Target, Range("E6:G" & r1_ & ",L6:N" & r1_))
[/vba]
К сообщению приложен файл: Test2_4.xlsm (21.0 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеЭто я неверно dd_ написал. Вот так нужно
[vba]
Код
    Set dd_ = Intersect(Target, Range("E6:G" & r1_ & ",L6:N" & r1_))
[/vba]

Автор - _Boroda_
Дата добавления - 08.06.2016 в 13:40
w00t Дата: Среда, 08.06.2016, 14:11 | Сообщение № 10
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 131
Репутация: 3 ±
Замечаний: 0% ±

Павел, привет
попробуйте вот так
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("Таблица1[[new Data1]:[new Data4]]")) Is Nothing Then Exit Sub
Target.Interior.ColorIndex = IIf(Target.Value = Target(1, -6).Value, 43, 7)
End Sub


Не заметил сразу, спасибо! Это про первый вариант, с умными таблицами.
Тогда приложу пожалуй, последний вариант, с кнопочкой создания умной таблицы, потому как вручную создавать тоже скучно.

[vba]
Код
Option Explicit

Sub test()

    Dim ListObj As ListObject
    
    On Error Resume Next
    Set ListObj = ActiveSheet.ListObjects("MyData")
    On Error GoTo 0
    
    If ListObj Is Nothing Then
        Set ListObj = ActiveSheet.ListObjects.Add(xlSrcRange, Range([B5].End(xlDown), [B5].End(xlToRight)), , xlYes)
        ListObj.Name = "MyData"
        ActiveSheet.ListObjects("MyData").Range.EntireColumn.ColumnWidth = 8.13
        ActiveSheet.ListObjects("MyData").TableStyle = ""
    Else: ActiveSheet.ListObjects("MyData").Unlist
    End If

End Sub
[/vba]

[vba]
Код
ActiveSheet.ListObjects("MyData").Range.EntireColumn.ColumnWidth = 8.13
[/vba] - это, потому что иначе AutoFit не отключается. Он сразу применяет какой-то стиль.
К сообщению приложен файл: _1606197_2.xlsm (23.5 Kb)
 
Ответить
Сообщение
Павел, привет
попробуйте вот так
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("Таблица1[[new Data1]:[new Data4]]")) Is Nothing Then Exit Sub
Target.Interior.ColorIndex = IIf(Target.Value = Target(1, -6).Value, 43, 7)
End Sub


Не заметил сразу, спасибо! Это про первый вариант, с умными таблицами.
Тогда приложу пожалуй, последний вариант, с кнопочкой создания умной таблицы, потому как вручную создавать тоже скучно.

[vba]
Код
Option Explicit

Sub test()

    Dim ListObj As ListObject
    
    On Error Resume Next
    Set ListObj = ActiveSheet.ListObjects("MyData")
    On Error GoTo 0
    
    If ListObj Is Nothing Then
        Set ListObj = ActiveSheet.ListObjects.Add(xlSrcRange, Range([B5].End(xlDown), [B5].End(xlToRight)), , xlYes)
        ListObj.Name = "MyData"
        ActiveSheet.ListObjects("MyData").Range.EntireColumn.ColumnWidth = 8.13
        ActiveSheet.ListObjects("MyData").TableStyle = ""
    Else: ActiveSheet.ListObjects("MyData").Unlist
    End If

End Sub
[/vba]

[vba]
Код
ActiveSheet.ListObjects("MyData").Range.EntireColumn.ColumnWidth = 8.13
[/vba] - это, потому что иначе AutoFit не отключается. Он сразу применяет какой-то стиль.

Автор - w00t
Дата добавления - 08.06.2016 в 14:11
nilem Дата: Среда, 08.06.2016, 14:22 | Сообщение № 11
Группа: Авторы
Ранг: Старожил
Сообщений: 1613
Репутация: 563 ±
Замечаний: 0% ±

Excel 2013, 2016
может, умная таблица вообще не нужна?
если будет просто диапазон, замените эту строку
[vba]
Код
If Intersect(Target, Range("Таблица1[[new Data1]:[new Data4]]")) Is Nothing Then Exit Sub
[/vba]

на вот эту
[vba]
Код
If Intersect(Target, Range("B5").CurrentRegion.Columns(11).Resize(, 3)) Is Nothing Then Exit Sub
[/vba]


Яндекс.Деньги 4100159601573

Сообщение отредактировал nilem - Среда, 08.06.2016, 14:23
 
Ответить
Сообщениеможет, умная таблица вообще не нужна?
если будет просто диапазон, замените эту строку
[vba]
Код
If Intersect(Target, Range("Таблица1[[new Data1]:[new Data4]]")) Is Nothing Then Exit Sub
[/vba]

на вот эту
[vba]
Код
If Intersect(Target, Range("B5").CurrentRegion.Columns(11).Resize(, 3)) Is Nothing Then Exit Sub
[/vba]

Автор - nilem
Дата добавления - 08.06.2016 в 14:22
w00t Дата: Среда, 08.06.2016, 15:24 | Сообщение № 12
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 131
Репутация: 3 ±
Замечаний: 0% ±

замените эту строку

Да, довольно коротко получилось. Форумчане меня уже расстреляют, но еще спрошу. Чтобы на каждое изменение на листе проверял и закрашивал эти ячейки?
У меня в сообщении 6 примитивно, но реагирует. Без разницы что поменял, он пробежал по ним.

А здесь нет. Раз ввел и все, выполнилось для конкретной пары ячеек. То есть что ранее было введено и имеет отличие - останется незакрашенным. Я когда удалил формулу условного форматирования - обнаружил это ... :(

Ладно, поковыряю еще, но вдруг..
 
Ответить
Сообщение
замените эту строку

Да, довольно коротко получилось. Форумчане меня уже расстреляют, но еще спрошу. Чтобы на каждое изменение на листе проверял и закрашивал эти ячейки?
У меня в сообщении 6 примитивно, но реагирует. Без разницы что поменял, он пробежал по ним.

А здесь нет. Раз ввел и все, выполнилось для конкретной пары ячеек. То есть что ранее было введено и имеет отличие - останется незакрашенным. Я когда удалил формулу условного форматирования - обнаружил это ... :(

Ладно, поковыряю еще, но вдруг..

Автор - w00t
Дата добавления - 08.06.2016 в 15:24
_Boroda_ Дата: Среда, 08.06.2016, 15:28 | Сообщение № 13
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
То есть что ранее было введено и имеет отличие - останется незакрашенным.

Скопируйте весь диапазон (или E:G, или L:N) и вставьте на то же место


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
Сообщение
То есть что ранее было введено и имеет отличие - останется незакрашенным.

Скопируйте весь диапазон (или E:G, или L:N) и вставьте на то же место

Автор - _Boroda_
Дата добавления - 08.06.2016 в 15:28
w00t Дата: Среда, 08.06.2016, 15:49 | Сообщение № 14
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 131
Репутация: 3 ±
Замечаний: 0% ±

Но это ж жесть. Большой диапазон копировать и вставлять на каждое измененире листа.
 
Ответить
СообщениеНо это ж жесть. Большой диапазон копировать и вставлять на каждое измененире листа.

Автор - w00t
Дата добавления - 08.06.2016 в 15:49
_Boroda_ Дата: Среда, 08.06.2016, 15:57 | Сообщение № 15
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Большой диапазон копировать и вставлять на каждое измененире листа

Это Вы сейчас о чем? Вы просили что?
что ранее было введено и имеет отличие - останется незакрашенным
Вам сказали - ОДИН раз нужно скопировать весь диапазон и вставить его на то же место. Перекрасится все то, что было покрашенным неверно. И все. После этого все изменения в файле будут отслеживаться автоматически.


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
Сообщение
Большой диапазон копировать и вставлять на каждое измененире листа

Это Вы сейчас о чем? Вы просили что?
что ранее было введено и имеет отличие - останется незакрашенным
Вам сказали - ОДИН раз нужно скопировать весь диапазон и вставить его на то же место. Перекрасится все то, что было покрашенным неверно. И все. После этого все изменения в файле будут отслеживаться автоматически.

Автор - _Boroda_
Дата добавления - 08.06.2016 в 15:57
w00t Дата: Среда, 08.06.2016, 16:38 | Сообщение № 16
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 131
Репутация: 3 ±
Замечаний: 0% ±

Мозг сломается... Я то имел в виду про участок кода Николая. Очень короткий уж он просто, симпатично.

А когда понял, что речь про ваш, то сделал так (разово копипаст, флагом).

[vba]
Код

    Public UpDateFlag As Boolean
    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim dd_ As Range, d_ As Range
    ad_ = Selection.Address
    r1_ = Range("D" & Rows.Count).End(xlUp).Row
    If r1_ < 6 Then Exit Sub
    Set dd_ = Intersect(Target, Range("E6:G" & r1_ & ":L6:N" & r1_))
    If Not dd_ Is Nothing Then
        Application.ScreenUpdating = 0
        tsv0_ = RGB(146, 208, 80)
        tsv1_ = RGB(255, 102, 204)
        sm_ = 7
        For Each d_ In dd_
            of_ = sm_ + 2 * sm_ * (d_.Column > 11)
            If d_.Column > 7 And d_.Column < 11 Then Exit Sub
            ofkr_ = -of_ * (of_ > 0)
'            d_.Offset(, ofkr_).Interior.Color = tsv0_
            If d_ <> d_.Offset(, of_) Then
                d_.Offset(, ofkr_).Interior.Color = tsv1_
            End If
        Next d_
    End If
If UpDateFlag = True Then Exit Sub
    Range("L6:N" & r1_).Copy
    Range("L6:N" & r1_).PasteSpecial (xlPasteValues)
    Application.CutCopyMode = 0
    Range(ad_).Select
UpDateFlag = True
End Sub
[/vba]


Сообщение отредактировал w00t - Среда, 08.06.2016, 16:43
 
Ответить
СообщениеМозг сломается... Я то имел в виду про участок кода Николая. Очень короткий уж он просто, симпатично.

А когда понял, что речь про ваш, то сделал так (разово копипаст, флагом).

[vba]
Код

    Public UpDateFlag As Boolean
    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim dd_ As Range, d_ As Range
    ad_ = Selection.Address
    r1_ = Range("D" & Rows.Count).End(xlUp).Row
    If r1_ < 6 Then Exit Sub
    Set dd_ = Intersect(Target, Range("E6:G" & r1_ & ":L6:N" & r1_))
    If Not dd_ Is Nothing Then
        Application.ScreenUpdating = 0
        tsv0_ = RGB(146, 208, 80)
        tsv1_ = RGB(255, 102, 204)
        sm_ = 7
        For Each d_ In dd_
            of_ = sm_ + 2 * sm_ * (d_.Column > 11)
            If d_.Column > 7 And d_.Column < 11 Then Exit Sub
            ofkr_ = -of_ * (of_ > 0)
'            d_.Offset(, ofkr_).Interior.Color = tsv0_
            If d_ <> d_.Offset(, of_) Then
                d_.Offset(, ofkr_).Interior.Color = tsv1_
            End If
        Next d_
    End If
If UpDateFlag = True Then Exit Sub
    Range("L6:N" & r1_).Copy
    Range("L6:N" & r1_).PasteSpecial (xlPasteValues)
    Application.CutCopyMode = 0
    Range(ad_).Select
UpDateFlag = True
End Sub
[/vba]

Автор - w00t
Дата добавления - 08.06.2016 в 16:38
nilem Дата: Среда, 08.06.2016, 16:49 | Сообщение № 17
Группа: Авторы
Ранг: Старожил
Сообщений: 1613
Репутация: 563 ±
Замечаний: 0% ±

Excel 2013, 2016
А здесь нет. Раз ввел и все, выполнилось для конкретной пары ячеек.

а если вот эдак вот:
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B5").CurrentRegion.Columns(11).Resize(, 3)) Is Nothing Then Exit Sub
Dim r As Range
For Each r In Target.Cells
    Select Case r.Column
        Case 12, 13, 14    ' 12, 13, 14 means columns L, M, N
            r.Interior.ColorIndex = IIf(r.Value = r(1, -6).Value, 43, 7)
    End Select
Next r
End Sub
[/vba]
edited
это код для обычного диапазона. Если все же нужна умная т-ца, попробуйте просто сохранить на листе маленькую умненькую табличку (:)), и при вставке она сама должна "разрастись" по размерам вставляемых данных


Яндекс.Деньги 4100159601573

Сообщение отредактировал nilem - Среда, 08.06.2016, 16:52
 
Ответить
Сообщение
А здесь нет. Раз ввел и все, выполнилось для конкретной пары ячеек.

а если вот эдак вот:
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B5").CurrentRegion.Columns(11).Resize(, 3)) Is Nothing Then Exit Sub
Dim r As Range
For Each r In Target.Cells
    Select Case r.Column
        Case 12, 13, 14    ' 12, 13, 14 means columns L, M, N
            r.Interior.ColorIndex = IIf(r.Value = r(1, -6).Value, 43, 7)
    End Select
Next r
End Sub
[/vba]
edited
это код для обычного диапазона. Если все же нужна умная т-ца, попробуйте просто сохранить на листе маленькую умненькую табличку (:)), и при вставке она сама должна "разрастись" по размерам вставляемых данных

Автор - nilem
Дата добавления - 08.06.2016 в 16:49
_Boroda_ Дата: Среда, 08.06.2016, 16:57 | Сообщение № 18
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
сделал так (разово копипаст, флагом)

Я Вам говорил про ручное единоразовое копирование-вставку. А Вы зачем-то суете все это в макрос.
Я не понимаю что Вы хотите. Вы зачем-то придумываете какие-то извращения непонятные, не объясняя при это, что же Вы хотите получить. И потом говорите, что у Вас не работает. Конечно не работает - код неверный. Извините, но мне надоело.
Ладно, заключительный раз.
Уберите свою переменную и повесьте кусок копи-пасте в событие открытия книги
[vba]
Код
Private Sub Workbook_Open()
    With Worksheet____1
        r1_ = .Range("D" & Rows.Count).End(xlUp).Row
        .Range("L6:N" & r1_).Copy .Range("L6:N" & r1_)
    End With
End Sub
[/vba]
К сообщению приложен файл: Test2_7.xlsm (18.5 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
Сообщение
сделал так (разово копипаст, флагом)

Я Вам говорил про ручное единоразовое копирование-вставку. А Вы зачем-то суете все это в макрос.
Я не понимаю что Вы хотите. Вы зачем-то придумываете какие-то извращения непонятные, не объясняя при это, что же Вы хотите получить. И потом говорите, что у Вас не работает. Конечно не работает - код неверный. Извините, но мне надоело.
Ладно, заключительный раз.
Уберите свою переменную и повесьте кусок копи-пасте в событие открытия книги
[vba]
Код
Private Sub Workbook_Open()
    With Worksheet____1
        r1_ = .Range("D" & Rows.Count).End(xlUp).Row
        .Range("L6:N" & r1_).Copy .Range("L6:N" & r1_)
    End With
End Sub
[/vba]

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

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