Excel vba как сравнить диапазоны - Word и Excel - помощь в работе с программами

Gorr98

Пользователь

Сообщений: 17
Регистрация: 29.06.2016

Подскажите пожалуйста, как организовать поиск на несовпадение?
На первом листе таблицу надо сравнить с таблицей на втором листе. Если найдены несовпадения, добавить не совпавшее значение в таблицу на первом листе.
В моем коде вроде находится, но не добавляется.

Прикрепленные файлы

П3.xlsm (20.69 КБ)

Юрий М

Модератор

Сообщений: 60570
Регистрация: 14.09.2012

Контакты см. в профиле

29.06.2016 18:50:38

Цитата
Gorr98 написал: В моем коде вроде находится, но не добавляется

Не находится, так как на втором листе нет значений, которые бы отсутствовали на первом.
См. мой вариант. Если значений ОЧЕНЬ много (тысячи строк), то есть смысл делать на массивах.
P.S. Чудной код у Вас )) Сами писали или где-то подсмотрели?

Прикрепленные файлы

П3 01.xlsm (22.26 КБ)

JeyCi

Пользователь

Сообщений: 3357
Регистрация: 27.11.2013

29.06.2016 19:56:42

а что делать с дублями в 1-й таблице?
и можно ли итог отсортировать (особенность запросов — автосортировка по ключевому полю…
если 1-е) нет не нужны и 2-е) да можно…
то SQL-запрос на добавление новых будет выглядеть так (как вариант)… для разнообразия

Код

SELECT t.Номер FROM `Лист1$` t
UNION
SELECT ttt.Номер FROM `Лист2$` ttt
WHERE ttt.Номер NOT IN (
SELECT t.Номер FROM `Лист1$` t
INNER JOIN  `Лист2$` tt
ON t.Номер=tt.Номер)

файл в папку C:1

Прикрепленные файлы

П3.xlsm (21.75 КБ)

Изменено: JeyCi — 29.06.2016 20:20:29

чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок — обратитесь к собеседнику на ВЫ — ответ на ваш вопрос получите — а остальное вас не касается (п.п.п. на форумах)

Мотя

Пользователь

Сообщений: 3218
Регистрация: 25.12.2012

29.06.2016 20:43:07

Цитата
JeyCi написал: а что делать с дублями в 1-й таблице?

1 таблица должна дополниться только новыми данными из 2 таблицы, т.е. 1 таблица может иметь кучу строк, представленных одним данным.

Gorr98

!
См. вариант «на массивах», о которых говорил

Юрий М

Прикрепленные файлы

П3-1.xlsm (23.02 КБ)

Gorr98

Пользователь

Сообщений: 17
Регистрация: 29.06.2016

Огого! Никогда бы не подумал, что это может быть так просто, да еще и в такое маленькое количество строк!

Спасибо большое, благодаря таким, как вы, чайники вроде меня черпают опыт чашками, а не ложками)

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

Hugo

Пользователь

Сообщений: 23249
Регистрация: 22.12.2012

30.06.2016 08:32:14

Цитата
Gorr98 написал: да еще и в такое маленькое количество строк!

так показали бы тут код где ещё меньше строк — тот с кибера от fever brain

Код

Sub Сравнение() Dim r1 As Range, r2 As Range, v, w, i& With Sheets(1) Set r1 = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)) End With With Sheets(2) Set r2 = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)) End With For Each v In r1 For Each w In r2 If v = w Then GoTo 1 Next i = i + 1: Sheets(1).Cells(i, 3) = v 1 Next MsgBox (Choose(Sgn(i) + 1, "Всё совпало", "Имеются различия смотрите колонку [C]")) End Sub

Только тут у него идёт сравнение обратное заказанному, но не суть.
Да и там есть добавка:

Код
Сравниваем второй лист с первым наоборот: For Each v In r2 For Each w In r1 If v = w Then GoTo 1 Next i = i + 1: Sheets(1).Cells(i, 3) = v 1 Next

Если данных много — добавкой rn=rn.value можно анализ перевести в массивы (только тип rn убрать).

Изменено: Hugo — 30.06.2016 08:33:02

Gorr98

Пользователь

Сообщений: 17
Регистрация: 29.06.2016

30.06.2016 16:59:30

Код

Sub Сравнить_2()
Dim i As Long, LastRow As Long, Rng As Range, FreeRow As Long
    FreeRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
    With Sheets("Лист2")
        LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 2 To LastRow
            Set Rng = Columns(1).Find(what:=.Cells(i, 1), LookIn:=xlFormulas, lookAt:=xlWhole)
            If Rng Is Nothing Then
                Cells(FreeRow, 1) = .Cells(i, 1)
                FreeRow = FreeRow + 1
            End If
        Next
    End With
End Sub

Юрий М, расскажите, пожалуйста, что означают приставки xl? Так и не смог разобраться. Знаю, что xlUp — это верхняя граница. Кстати, почему мы используем верхнюю границу, а не нижнюю? С нижней попробовал — не работает. Но ведь мы используем последнее значение снизу — почему тогда xlUp?

Set Rng = Columns(1).Find(what:=.Cells(i, 1), LookIn:=xlFormulas, lookAt:=xlWhole) — а в этой строке такая логика, что задаем Rng первую колонку и ищем ее в первой колонке добавленного листа, верно? Если да, то what тут означает «ищем совпадение»? А что значат LookIn и lookAt?

Надеюсь, что не сильно завалил вопросами :oops:

Hugo

Пользователь

Сообщений: 23249
Регистрация: 22.12.2012

По второму вопросу — задаём не первую колонку, а задаём найти. И ищем в первой колонке что, в чём и как.
И если нашлось, то… далее по коду.

А xlUp — это вверх. Вверх от в данном случае последней ячейки столбца, пока не наткнёмся на значение.
Можно идти и вниз от первой — но обычно ведь бывают пустые ячейки…

Юра, я пришёл — а тебя нет…

Изменено: Hugo — 30.06.2016 17:20:23

Юрий М

Модератор

Сообщений: 60570
Регистрация: 14.09.2012

Контакты см. в профиле

30.06.2016 17:13:02

Всякие xl — это своего рода константы-сокращения: xlFormulas, xlWhole, xlNone, XlYesNo и т.д. Т.е. «готовые к употреблению» параметры )

Цитата
Gorr98 написал: что значат LookIn и lookAt?

what — какое значение ищем.
LookIn — где ищем. Варианты: значения или формулы.
lookAt — точное совпадение или частичное.

Gorr98

Пользователь

Сообщений: 17
Регистрация: 29.06.2016

О! с what, lookIn и lookAt понятно стало, а вот xlUp не совсем — выходит, да, бывают пустые ячейки, на которые xlDown наткнется и подумает, что это конец данных. Но xlUP ведь тоже должен тогда споткнуться об эту же пустую ячейку?
А насчет констант-сокращений — есть какой-то список этих сокращений?

И еще, если возможно, посоветуйте, пожалуйста, какую-нибудь литературу по vba

Hugo

Пользователь

Сообщений: 23249
Регистрация: 22.12.2012

xlUP идёт снизу вверх, по пустым, он наткнётся на первую заполненную. Снизу!
А xlDown пускают свеху вниз по полным, он тормознёт на пустой.
Иногда нужно использовать xlDown — например чтоб пройтись по плотно заполненной таблице, под которой ниже ещё есть данные, после пустых ячеек.

список этих сокращений — в редакторе жмёте F2, там всё.

Изменено: Hugo — 30.06.2016 18:01:31

С.М.

Пользователь

Сообщений: 936
Регистрация: 22.12.2012

#12

30.06.2016 21:36:14

Вариант с xlDown:

Код

Sub Test2()
    Dim Rng1 As Range, Rng2 As Range, Counts(), Arr3(), N As Long, J As Long, K As Long
    Set Rng1 = Лист1.Range("A2")
    Set Rng1 = Range(Rng1, Rng1.End(xlDown))
    Set Rng2 = Лист2.Range("A2")
    Set Rng2 = Range(Rng2, Rng2.End(xlDown))
    Counts = Evaluate("INDEX(COUNTIF(" & Rng1.Address(External:=True) & "," & Rng2.Address(External:=True) & "),0,0)")
    N = Rng2.Rows.Count
    ReDim Arr3(1 To N, 1 To 1)
    For K = 1 To N
        If Counts(K, 1) = 0 Then
            J = J + 1
            Arr3(J, 1) = Rng2.Cells(K, 1)
        End If
    Next
    MsgBox "Найдено несовпадений: " & J, , ""
    Rng1.Cells(Rng1.Rows.Count + 1).Resize(N).Value = Arr3
End Sub

Прикрепленные файлы

Сравнение двух диапазонов на несовпадение.xls (55 КБ)

Источник

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

Сравнение двух диапазонов ячеек на совпадение

29.05.2012, 00:04. Показов 23504. Ответов 20

Здравствуйте! Подскажите пожалуйста…
Имеется 2 диапазона ячеек А1:A3 и C1:C3, в которых забиты цифры, допустим в ячейках А1:A3 (3,6,2 соответственно), а в C1:C3 (2, 4, и мне необходимо, чтобы при нахождении одинаковых значений выводилось сообщение. Спасибо

~~Апострофф~~

Заблокирован

29.05.2012, 06:59

Visual Basic

Sub cmp()
Dim a As Range, c As Range
For Each a In [A1:A3]
  For Each c In [C1:C3]
    If a = c Then MsgBox a & "=" & c
  Next c
Next a
End Sub

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

31.05.2012, 13:37

[ТС]

Спасибо, а как сделать чтобы этот же код продолжал работать в след.ячейках например не А1:А3 и С1:С3, а изменил диапазон со сдвигом вправо, т.е. В1:В3 и D1: D3 стало, чтобы не писать его для всех ячеек, а просто со сдвигом вправо? Спасибо

17991 / 7617 / 890

Регистрация: 25.12.2011

Сообщений: 11,351

Записей в блоге: 17

01.06.2012, 09:20

И сколько таких сдвигов планируется?

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

01.06.2012, 13:00

[ТС]

Примерно 30 сдвигов

Dragokas

17991 / 7617 / 890

Регистрация: 25.12.2011

Сообщений: 11,351

Записей в блоге: 17

01.06.2012, 16:15

Сообщение было отмечено как решение

Решение

1. Прокрутка через смещения
2. Исключено сравнение пустых строк
3. Информация о позиции найденных ячеек

Visual Basic

Sub cmp()
Dim a As Range, c As Range, n As Integer
For n = 0 To 30 'êîë-âî ñìåùåíèé
  For Each a In [A1:A3].Offset(, n)
    For Each c In [C1:C3].Offset(, n)
      If a = c And Len(a) <> 0 Then MsgBox a & "=" & c & " (" & _
        Replace(a.Address & " = " & c.Address & ")", "$", "")
Next c, a, n
End Sub

ikki

призрак

3261 / 889 / 119

Регистрация: 11.05.2012

Сообщений: 1,702

Записей в блоге: 2

01.06.2012, 16:38

Сообщение от Diskretor

Visual Basic

1	Replace(a.Address & " = " & c.Address & ")", "$", "")

а так не проще?

Visual Basic

1	a.Address(0,0) & " = " & c.Address(0,0)

Dragokas

01.06.2012, 17:23

Не по теме:

Да, я забыл как это делается. Спасибо.

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

01.06.2012, 22:54

[ТС]

Спасибо!

Сообщение от Diskretor

Len(a) <> 0

а что значит эта строка?

17991 / 7617 / 890

Регистрация: 25.12.2011

Сообщений: 11,351

Записей в блоге: 17

02.06.2012, 05:16

Без нее, если попадутся 2 пустые ячейки, начнет писать о совпадении.

У меня они были почти все пустые, поэтому я это дело отключил.

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

02.06.2012, 08:45

[ТС]

Спасибо! Как раз то, что нужно.

irealife

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

03.07.2012, 23:15

[ТС]

Visual Basic

Dim a As Range, c As Range, n As Integer
For n = 0 To 150 Step 3 'кол-во смещений
  For Each a In [F3:H3].Offset(, n)
    For Each c In [CC3:CE3].Offset(, n)
      If a = c And Len(a) <> 0 Then letters8 = letters8 + 1
Next c, a, n

Подскажите пожалуйста, а как написать так, чтобы к letters8 прибавлялось 1 при одном совпадении и прибавлялась 2 при больше двух совпадениях.

Dragokas

17991 / 7617 / 890

Регистрация: 25.12.2011

Сообщений: 11,351

Записей в блоге: 17

04.07.2012, 02:51

Если правильно Вас понял, общее кол-во совпадений считаем, как сумму любых совпадений значений в 3 х 3 ячеек в текущем смещении. При этом, если совпадений ровно 2, то ничего не прибавляем.

Visual Basic

Dim a As Range, c As Range, n As Integer, k As Integer
For n = 0 To 150 Step 3 'кол-во смещений
  k = 0
  For Each a In [F3:H3].Offset(, n)
    For Each c In [CC3:CE3].Offset(, n)
      If a = c And Len(a) <> 0 Then k = k + 1
    Next
  Next
  Select Case k
    Case 1
      letters8 = letters8 + 1
    Case Is > 2
      letters8 = letters8 + 2
  End Select
Next

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

07.07.2012, 13:52

[ТС]

При выполнении данного кода, у меня при 1 совпадении все правильно происходит, а при больше двух к letters8 прибавляется 5 вместо 2.

17991 / 7617 / 890

Регистрация: 25.12.2011

Сообщений: 11,351

Записей в блоге: 17

07.07.2012, 14:09

Так здесь добавляется сразу же, как только найдет совпадения в одном смещении.
А Вам нужно, чтобы после просчета всех 150/3 ?

Тогда строку № 15 переместите между 8 и 9 (а № 3 удалить).

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

07.07.2012, 15:31

[ТС]

У меня снова не выходит, теперь получается так, что при любом количестве совпадений прибавляется к letters8 значение 2, а должно, чтобы при отсутствии совпадений — не прибавляться ничего, при одном совпадении — прибавляться единица. И проблема по-моему в переменной k. Я в ячейки добавляю все разные значения, а k он мне выводит равное трем, поэтому и прибавляется все время 2 к letters8.

17991 / 7617 / 890

Регистрация: 25.12.2011

Сообщений: 11,351

Записей в блоге: 17

07.07.2012, 22:30

Можете выложить файл с некоторыми фрагментами цифер для теста.

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

08.07.2012, 01:15

[ТС]

А вы можете почту написать свою? я на почту скину файл?

Добавлено через 2 часа 23 минуты
Diskretor, спасибо! Я поняла в чем ошибка была)

Добавлено через 13 минут
Последний вопрос по теме: имеется массив значений в excel и выполняется огромный код на строку 3. Необходимо сделать так, чтобы этот же код выполнялся на все заполненные последующие строки в excel. В самом коде было использовано свойство Range с конкретным указанием на ячейки в строке.

Dragokas

17991 / 7617 / 890

Регистрация: 25.12.2011

Сообщений: 11,351

Записей в блоге: 17

08.07.2012, 02:03

Да? А я — нет. Можете просветить, чтобы в следующий раз тоже знать как правильно объяснять?

Visual Basic

Dim Rng As Range, c As Range, n%, k%, R%
Dim letters8(3 To 10)
For R = 3 To 10 'номера строк
  For n = 0 To 150 Step 3 'кол-во смещений
    k = 0 'в каждом смещении вправо K подсчитываем отдельно
    For Each Rng In Range("F" & R & ":H" & R).Offset(, n)
      For Each c In Range("CC" & R & ":CE" & R).Offset(, n)
        If Rng = c And Len(Rng) <> 0 Then k = k + 1
      Next
    Next
    Select Case k
      Case 1
        letters8(R) = letters8(R) + 1
      Case Is > 2
        letters8(R) = letters8(R) + 2
    End Select
  Next n
Next R

Из леттерсов тоже сделал массив, так как не знал они теперь отдельно подсчитываются или складываются из всех строк. Если что поубираете массивы (скобки).

irealife

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

08.07.2012, 10:30

[ТС]

Вы в самом начале правильно мне все написали, ошибка у меня была в диапазоне: было от 0 до 150, а нужно было от 0 до 75, и в кейсах у меня он не понимал что такое Case 1, поэтому я ему указала конкретно на равенство через Case Is. И все, спасибо вам)

Visual Basic

Dim a As Range, c As Range, n As Integer, k As Integer
For n = 0 To 75 Step 3 'кол-во смещений
  For Each a In [F3:H3].Offset(, n)
    For Each c In [CC3:CE3].Offset(, n)
      If a = c And Len(a) <> 0 Then k = k + 1
    Next
  Next
Next
'MsgBox k
  Select Case k
    Case Is = 1
      letters8 = letters8 + 1
    Case Is >= 2
      letters8 = letters8 + 2
  End Select

Источник

Содержание

Vba excel как сравнить диапазоны
Vba excel как сравнить диапазоны
Vba excel как сравнить диапазоны
Сравнение таблиц в Excel с помощью макросов VBA

Vba excel как сравнить диапазоны

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

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

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

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

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

В целом все так в оригинальной табличке, только данные другие и она большая. Я потом по вот этим отличиям фильтрую по цвету, наглядно видно. Автор — w00t
Дата добавления — 07.06.2016 в 20:42

_Boroda_

Дата: Вторник, 07.06.2016, 20:51 | Сообщение № 2

Ответить

w00t

Дата: Вторник, 07.06.2016, 21:55 | Сообщение № 3

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

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

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

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

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

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

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

Источник

Vba excel как сравнить диапазоны

staniiislav, в общем нормально, но если делать так — то массив с() лишний. Можно ведь сразу

If .Exists(u) Then Sheets(«Заказы»).Range(Sheets(«Зака зы»).Cells(i, 1), Sheets(«Заказы»).Cells(i, 11)).Interior.ColorIndex = 37

Доп. массив я думал использовать так — заполнили как у Вас (только зачем Else c(i, 1) = Empty?), затем выгрузили в свободный столбец, далее с помощью specialcells сразу весь нужный диапазон одним махом покрасили, затем метки удалили (тоже одним движением).

хотя так будет быстрее:

staniiislav, в общем нормально, но если делать так — то массив с() лишний. Можно ведь сразу

If .Exists(u) Then Sheets(«Заказы»).Range(Sheets(«Зака зы»).Cells(i, 1), Sheets(«Заказы»).Cells(i, 11)).Interior.ColorIndex = 37

ну да))) , чет сразу не додумал ) ща поправим! СПАСИБО, а Empty так, чтобы было )))

добавлено позже:

тогда вообще так получается (как вы подправили):

В том то и дело — если красить нужно много, то именно на этом и будет основная потеря времени.
Поэтому всю эту операцию нужно постараться сделать за один приём.
Ну а если прогноз, что красить будем примерно 10 строк — то Ваш код уже нет смысла улучшать, разница в скорости будет не заметна.

Переменная u в общем тоже лишняя — т.к. используется всего 1 раз. Если использовать чаще (как я обычно использовал t) — тогда смысл есть, чтоб много раз не лезть в массив и не конкатенировать

Источник

Vba excel как сравнить диапазоны

Есть два файла — book1 и book2. Написал простенький макрос чтобы сравнивало уникальные значения в столбцах B (обоих книг) и при нахождении совпадения подставляло значения из 3-го столбца book2 в третий столбец book1. Книжки в одной папке. Макрос в модуле первой книги

200?’200px’:»+(this.scrollHeight+5)+’px’);»> Sub compare()
Dim compareRange As Variant, compareRange1 As Variant, x As Variant, y As Variant

Set compareRange = Sheets(«sheet1»).Range(«B2:B6»)
Set compareRange1 = Workbooks(«book2.xls»).Sheets(«sheet1»).Range(«B2:B6»)

For Each x In compareRange
For Each y In compareRange1

If x = y Then x.Offset(0, 1) = y.Offset(0, 1)

Забыл добавить — ничего не происходит при выполнении макроса.

200?’200px’:»+(this.scrollHeight+5)+’px’);»> Sub compare()
Dim compareRange As Variant, compareRange1 As Variant, x As Variant, y As Variant

Set compareRange = Sheets(«sheet1»).Range(«B2:B6»)
Set compareRange1 = Workbooks(«book2.xls»).Sheets(«sheet1»).Range(«B2:B6»)

For Each x In compareRange
For Each y In compareRange1

If x = y Then x.Offset(0, 1) = y.Offset(0, 1)

Забыл добавить — ничего не происходит при выполнении макроса. Treider01

Сообщение Добрый день.

200?’200px’:»+(this.scrollHeight+5)+’px’);»> Sub compare()
Dim compareRange As Variant, compareRange1 As Variant, x As Variant, y As Variant

Set compareRange = Sheets(«sheet1»).Range(«B2:B6»)
Set compareRange1 = Workbooks(«book2.xls»).Sheets(«sheet1»).Range(«B2:B6»)

For Each x In compareRange
For Each y In compareRange1

If x = y Then x.Offset(0, 1) = y.Offset(0, 1)

Забыл добавить — ничего не происходит при выполнении макроса. Автор — Treider01
Дата добавления — 01.12.2014 в 15:28

Источник

Сравнение таблиц в Excel с помощью макросов VBA

Оставлен Adm вс, 09/11/2014 — 21:30

Статья даёт ответы на следующие вопросы:

Как сравнить две таблицы в Excel с помощью макросов VBA?
Как обращаться к ячейкам таблицы Excel с помощью VBA?
Как осуществлять перебор ячеек таблицы в цикле с помощью VBA?

В предыдущей статье Сравнение таблиц в Excel мы рассмотрели подход к сравнению сложных таблиц с использованием формул и без программирования.

В данной статье рассмотрим способ сравнения таблиц Excel с помощью VBA макросов на примере тех же исходных данных.

Проиллюстрируем задачу картинкой из первой статьи.

Для начала напишем алгоритм наших действий по сравнению таблиц.

Определим диапазоны данных первой и второй таблицы, то есть найдем последние значимые строки и сохраним их номера в переменных (последняя строка таблицы 1 — last_i и последняя строка таблицы 2 — last_j).
Начнем проходить по каждой строке таблицы 2 (внешний цикл), данные из которой нужно перенести в таблицу 1. С первой строки данных (в примере это строка 3) до последней строки таблицы 2.
Для каждой строки таблицы 2 определим идентификатор строки, путем формирования строки, содержащей полный адрес квартиры (значения из нескольких колонок, разделенные дефисами).
Начнем проходить по каждой строке таблицы 1 (внутренний цикл) с первой строки данных (в примере это строка 3) до последней строки таблицы 1, определяя при этом идентификатор строки.
Сравним значения идентификаторов строк таблицы 1 и таблицы 2.
Если идентификаторы равны, перепишем ФИО покупателя из ячейки таблицы 2 в соответствующую ячейку таблицы 1; прервем внутренний цикл по таблице 1 и перейдем к следующей строке таблицы 2 (переход к п.2).

Теперь остается реализовать алгоритм в виде программного кода макроса.

Для этого откроем вкладку Вид ленты функций Excel. Щелкнем на нижнюю часть со стрелкой кнопки Макросы. В открывшемся подменю выберем Запись макроса. В результате начнется запись нового макроса. Поскольку код мы будем формировать вручную, то еще раз зайдем в подменю макросов и выберем Остановить запись. Далее еще раз войдем в подменю макросов и выберем Макросы.

В появившемся диалоге выделим наш макрос и нажмем Изменить.

На экране откроется окно редактора макросов Visual Basic for Applications. В области кода (правая верхняя область) отображается код только что созданного пустого макроса.

В процедуру Макрос1 (между объявлениями начала и конца процедуры: Sub и End Sub) необходимо вставить код, решающий поставленную задачу. Образец кода представлен ниже.

Результат решения задачи:

Источник

Сравнение двух диапазонов с подсветкой отличий

w00t

Дата: Вторник, 07.06.2016, 20:42 |
Сообщение № 1

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация:
3
±

Замечаний:
0% ±

1. [vba]

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

К сообщению приложен файл:

1606197.xlsm
(12.9 Kb)

Ответить

_Boroda_

Дата: Вторник, 07.06.2016, 20:51 |
Сообщение № 2

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618

Репутация:
6465
±

Замечаний:
0% ±

2003; 2007; 2010; 2013 RUS

А Условным форматированием?
Формула

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

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

Ответить

w00t

Дата: Вторник, 07.06.2016, 21:55 |
Сообщение № 3

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация:
3
±

Замечаний:
0% ±

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

[vba]

Код

Sub TestSmartTable()
ActiveSheet.ListObjects.Add(xlSrcRange, Range(«B5»).CurrentRegion, , xlYes).Name = «Table2»
End Sub

[/vba]

Сообщение отредактировал w00t — Вторник, 07.06.2016, 22:47

Ответить

w00t

Дата: Вторник, 07.06.2016, 23:04 |
Сообщение № 4

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация:
3
±

Замечаний:
0% ±

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

Ответить

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)

Ответить

nilem

Дата: Среда, 08.06.2016, 10:15 |
Сообщение № 6

Группа: Авторы

Ранг: Старожил

Сообщений: 1612

Репутация:
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

Ответить

_Boroda_

Дата: Среда, 08.06.2016, 11:15 |
Сообщение № 7

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618

Репутация:
6465
±

Замечаний:
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)

Ответить

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

Ответить

_Boroda_

Дата: Среда, 08.06.2016, 13:40 |
Сообщение № 9

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618

Репутация:
6465
±

Замечаний:
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)

Ответить

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 не отключается. Он сразу применяет какой-то стиль.

Ответить

nilem

Дата: Среда, 08.06.2016, 14:22 |
Сообщение № 11

Группа: Авторы

Ранг: Старожил

Сообщений: 1612

Репутация:
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

Ответить

w00t

Дата: Среда, 08.06.2016, 15:24 |
Сообщение № 12

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация:
3
±

Замечаний:
0% ±

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

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

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

Ответить

_Boroda_

Дата: Среда, 08.06.2016, 15:28 |
Сообщение № 13

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618

Репутация:
6465
±

Замечаний:
0% ±

2003; 2007; 2010; 2013 RUS

То есть что ранее было введено и имеет отличие — останется незакрашенным.

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

Ответить

w00t

Дата: Среда, 08.06.2016, 15:49 |
Сообщение № 14

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация:
3
±

Замечаний:
0% ±

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

Ответить

_Boroda_

Дата: Среда, 08.06.2016, 15:57 |
Сообщение № 15

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618

Репутация:
6465
±

Замечаний:
0% ±

2003; 2007; 2010; 2013 RUS

Большой диапазон копировать и вставлять на каждое измененире листа

Это Вы сейчас о чем? Вы просили что?

что ранее было введено и имеет отличие — останется незакрашенным

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

Ответить

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

Ответить

nilem

Дата: Среда, 08.06.2016, 16:49 |
Сообщение № 17

Группа: Авторы

Ранг: Старожил

Сообщений: 1612

Репутация:
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

Ответить

_Boroda_

Дата: Среда, 08.06.2016, 16:57 |
Сообщение № 18

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618

Репутация:
6465
±

Замечаний:
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)

Ответить

Источник