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

If I understand your problem correctly, the following code should allow you to do what you want. Within the code, you select the range you wish to process; the first column of each data set, and the number of columns within each data set.

It does assume only two data sets, as you wrote, although that could be expanded. And there are ways of automatically determining the dataset columns, if there is no other data in between.

Option Explicit
Option Base 0
Sub RemoveDups()
    Dim I As Long, J As Long
    Dim rRng As Range
    Dim vRng As Variant, vRes() As Variant
    Dim bRng() As Boolean
    Dim aColumns, lColumns As Long
    Dim colRowsDelete As Collection

'vRng to include from first to last column to be tested
Set rRng = Range("f1", Cells(Rows.Count, "F").End(xlUp)).Resize(columnsize:=100)
vRng = rRng
ReDim bRng(1 To UBound(vRng))

'columns to be tested
'Specify First column of each data set
aColumns = Array(1, 13)

'num columns in each data set
lColumns = 3

For I = 1 To UBound(vRng)
    bRng(I) = vRng(I, aColumns(0)) = vRng(I, aColumns(1))
    For J = 1 To lColumns - 1
        bRng(I) = bRng(I) And (vRng(I, aColumns(0) + J) = vRng(I, aColumns(1) + J))
    Next J
Next I

'Rows to Delete
Set colRowsDelete = New Collection
For I = 1 To UBound(bRng)
    If bRng(I) = True Then colRowsDelete.Add Item:=I
Next I

'Delete the rows
If colRowsDelete.Count > 0 Then
Application.ScreenUpdating = False
    For I = colRowsDelete.Count To 1 Step -1
        rRng.Rows(colRowsDelete.Item(I)).EntireRow.Delete
    Next I
End If
Application.ScreenUpdating = True
End Sub

Источник

2 / 2 / 0

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

Сообщений: 45

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

29.05.2012, 00:04. Показов 23526. Ответов 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 стало, чтобы не писать его для всех ячеек, а просто со сдвигом вправо? Спасибо

17992 / 7618 / 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

17992 / 7618 / 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

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

17992 / 7618 / 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

17992 / 7618 / 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.

17992 / 7618 / 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.

17992 / 7618 / 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

17992 / 7618 / 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

Источник

Gorr98

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

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

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

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

П3.xlsm (20.69 КБ)

Юрий М

Модератор

Сообщений: 60575
Регистрация: 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

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

Сообщений: 23251
Регистрация: 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

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

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

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

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

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

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

Юрий М

Модератор

Сообщений: 60575
Регистрация: 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

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

Сообщений: 23251
Регистрация: 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 КБ)

Источник

You can use a simple MATCH formula to detect any non matches, then delete them with AutoFilter

If your first list was in Sheet 1 Column A, your second in Sheet 2 Column A then in B1 of Sheet 2 put
=ISNA(MATCH(A1,Sheet1!A:A,0))
and copy down

this returns TRUE where the second list cant be matched against the first. You can then delete these TRUE rows with autofilter

Note that you could also use
=COUNTIF(Sheet1!A:A,A1)=0
for the same effect to identify not matches (as TRUE)

xl2010 pic shown here

[VBA added]

Sub QuickKill()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rng1 As Range
    Set ws1 = Sheets(1)
    Set ws2 = Sheets(2)
    ws2.Columns(2).Insert
    Set rng1 = ws2.Range(ws2.[a1], ws2.Cells(Rows.Count, "A").End(xlUp))
    Rows(1).Insert
    With rng1.Offset(0, 1)
        .FormulaR1C1 = "=COUNTIF('" & ws1.Name & "'!C1,RC[-1])=0"
        .AutoFilter Field:=1, Criteria1:="TRUE"
        .EntireRow.Delete
        .EntireColumn.Delete
    End With
End Sub

Источник