Форум программистов, компьютерный форум, киберфорум
Наши страницы
VBA
Войти
Регистрация
Восстановить пароль
 
Рейтинг 4.83/6: Рейтинг темы: голосов - 6, средняя оценка - 4.83
ZatX
3 / 3 / 1
Регистрация: 15.05.2017
Сообщений: 48
1

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

12.12.2017, 14:20. Просмотров 1186. Ответов 10
Метки нет (Все метки)

Добрый день уважаемые форумчане! Нашёл в инете такой вот код:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
Option Explicit
 
    Sub compare()
    Dim a, b, c, t$, i&, ii&, x&, k
 
    '1.
 
    a = Sheets(1).[a1].CurrentRegion.Value
    b = Sheets(2).[a1].CurrentRegion.Value
 
    '2.
    ReDim c(1 To UBound(a) + UBound(b), 1 To UBound(a, 2))
 
    '3.
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a)
            t = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5)
            .Item(t) = i
        Next
 
        '4.
        For i = 1 To UBound(b)
            t = b(i, 1) & "|" & b(i, 2) & "|" & b(i, 3) & "|" & b(i, 4) & "|" & b(i, 5)
 
            If .exists(t) Then
                .Item(t) = 0
            Else
                ii = ii + 1
                For x = 1 To UBound(b, 2)
                    c(ii, x) = b(i, x)
                Next
            End If
        Next
 
        For Each k In .keys
            If .Item(k) <> 0 Then
                i = .Item(k): ii = ii + 1
                For x = 1 To UBound(a, 2)
                    c(ii, x) = a(i, x)
                Next
            End If
        Next
    End With
 
    '5.
    With Sheets(3)
    .[e1].Resize(ii).NumberFormat = "@"
    .[a1].Resize(ii, 5) = c
    End With
End Sub
Но он сравнивал (проверял) два списка, и выгружал несовпадающие на другой лист но в один диапазон, а мне нужно, чтоб "мухи отдельно от котлет были"
Подстроил его под свои нужды (пример кода в файле) к слову, мои переделки рабочие оказались, так как я не спец) но чувствую что логика моя не верна. Покажите кто-нибудь правильность для наглядности (со словарями+массивы трудно у меня всё пока). Заранее благодарю.
0
Вложения
Тип файла: xls Microsoft Excel Worksheet (2).xls (58.5 Кб, 10 просмотров)
Лучшие ответы (1)
QA
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
12.12.2017, 14:20
Ответы с готовыми решениями:

Макрос для копирования двух диапазонов с формулами в активный лист любой другой книги
Пытался сделать с помощью записи макросов, не работает. Копирует только последний диапазон....

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

Сравнение двух диапазонов ячеек на совпадение
Здравствуйте! Подскажите пожалуйста... Имеется 2 диапазона ячеек А1:A3 и C1:C3, в которых забиты...

Сравнение двух диапазонов по последней строке
Здравствуйте, Проблема такова. Необходимо сравнить значения в последних строках двух диапазонов,...

Сравнение двух диапазонов на идентичность без анализа отдельных ячеек
Здравствуйте! Подскажите, как сравнить два диапазона на результат ЛОЖЬ или ИСТИНА (в коде 10-я...

10
Hugo121
6508 / 2556 / 459
Регистрация: 19.10.2012
Сообщений: 7,672
12.12.2017, 14:33 2
Код мой, и там в оригинале выше каждый пункт был расписан.
Но т.к. файл с макросом скачать не могу - ничего более по этой задаче (про мух) пока прокомментировать не могу.
0
ZatX
3 / 3 / 1
Регистрация: 15.05.2017
Сообщений: 48
12.12.2017, 17:29  [ТС] 3
Hugo121, Добрый день) Помогите пожалуйста . Он сравнивает два диапазона на двух листах, и выгружает на третий лист все уникальные значения в один диапазон (как я описывал работу макроса ранее) и как Вы сами понимаете по своему творению) Моя задача - выгрузить значения двух листов раздельно. Допустим: в третьем листе "Мухи"- это "Лист1", а "Котлеты" - это"Лист2". Отводим "мухам"- Range("A1:C"), а "Котлетам" - Range("E1:G") грубо говоря, углубляясь в метафору)

Добавлено через 3 минуты
Вот что получилось у меня в итоге:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
Option Explicit
 
Sub compare()
    Dim a, b, c, d, t$, i&, ii&, x&, k
    Dim Dic1 As Object, Dic2 As Object
 
    Application.ScreenUpdating = False
    
    '1.
 
    a = Sheets(1).[a2].CurrentRegion.Value
    b = Sheets(2).[a2].CurrentRegion.Value
 
    '2.
    ReDim c(1 To UBound(a), 1 To UBound(a, 2))
    ReDim d(1 To UBound(b), 1 To UBound(b, 2))
 
    '3.
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Set Dic2 = CreateObject("Scripting.Dictionary")
 
    With Dic1
        For i = 1 To UBound(a)
            t = a(i, 1) & "|" & a(i, 3)
            .Item(t) = i
        Next
 
        '4.
        For i = 1 To UBound(b)
            t = b(i, 1) & "|" & b(i, 3)
 
            If .exists(t) Then
                .Item(t) = 0
            End If
        Next
 
        For Each k In .keys
            If .Item(k) <> 0 Then
                i = .Item(k): ii = ii + 1
                
                For x = 1 To UBound(a, 2)
                    c(ii, x) = a(i, x)
                Next
            End If
        Next
    End With
    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "Разница"
 
    '5.
    With Sheets("Разница")
    .[a2].Resize(ii, 3) = c
 
    End With
 
    End With
    
    ii = 0
    
    '3.
    
    With Dic2
        For i = 1 To UBound(b)
            t = b(i, 1) & "|" & b(i, 3)
            .Item(t) = i
        Next
 
        '4.
        For i = 1 To UBound(a)
            t = a(i, 1) & "|" & a(i, 3)
 
            If .exists(t) Then
                .Item(t) = 0
            End If
        Next
 
        For Each k In .keys
            If .Item(k) <> 0 Then
                i = .Item(k): ii = ii + 1
                
                For x = 1 To UBound(b, 2)
                    d(ii, x) = b(i, x)
                Next
            End If
        Next
    End With
 
    '5.
    With Sheets("Разница")
    .[e2].Resize(ii, 3) = d
 
      End With
  Application.ScreenUpdating = True
 
End Sub
Кажется что второй словарь я объявил зря, это то что заметил.
0
Hugo121
6508 / 2556 / 459
Регистрация: 19.10.2012
Сообщений: 7,672
12.12.2017, 20:56 4
Ну в целом нормально, так чуть изменил чтоб отработало на том файле, с существующим уже листом:
Кликните здесь для просмотра всего текста

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
Option Explicit
 
Sub compare()
    Dim a, b, c, d, t$, i&, ii&, x&, k
    Dim Dic1 As Object, Dic2 As Object
 
    Application.ScreenUpdating = False
 
    '1.
 
    a = Sheets(1).[a1].CurrentRegion.Value
    b = Sheets(2).[a1].CurrentRegion.Value
 
    '2.
    ReDim c(1 To UBound(a), 1 To UBound(a, 2))
    ReDim d(1 To UBound(b), 1 To UBound(b, 2))
 
    '3.
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Set Dic2 = CreateObject("Scripting.Dictionary")
 
    With Dic1
        For i = 1 To UBound(a)
            t = a(i, 1) & "|" & a(i, 3)
            .Item(t) = i
        Next
 
        '4.
        For i = 1 To UBound(b)
            t = b(i, 1) & "|" & b(i, 3)
 
            If .exists(t) Then
                .Item(t) = 0
            End If
        Next
 
        For Each k In .keys
            If .Item(k) <> 0 Then
                i = .Item(k): ii = ii + 1
 
                For x = 1 To UBound(a, 2)
                    c(ii, x) = a(i, x)
                Next
            End If
        Next
    End With
    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "Разница" & Sheets.Count
 
    '5.
    Sheets("Разница" & Sheets.Count - 1).[a2].Resize(ii, 3) = c
 
 
    '    End With '========это было лишнее, видать код не проверяли!=====================
 
    ii = 0
 
    '3.
 
    With Dic2
        For i = 1 To UBound(b)
            t = b(i, 1) & "|" & b(i, 3)
            .Item(t) = i
        Next
 
        '4.
        For i = 1 To UBound(a)
            t = a(i, 1) & "|" & a(i, 3)
 
            If .exists(t) Then
                .Item(t) = 0
            End If
        Next
 
        For Each k In .keys
            If .Item(k) <> 0 Then
                i = .Item(k): ii = ii + 1
 
                For x = 1 To UBound(b, 2)
                    d(ii, x) = b(i, x)
                Next
            End If
        Next
    End With
 
    '5.
    Sheets("Разница" & Sheets.Count - 1).[e2].Resize(ii, 3) = d
 
    Application.ScreenUpdating = True
 
End Sub

На словаре и массивах можно сэкономить память - использовать словарь и выгружаемый массив повторно, зачем помнить то, что уже не нужно.
Ну или сэкономить скорость - при цикле по массиву b сразу делать обе работы: проверяем наличие в первом словаре и заполняем второй. Но эта головоломка может и не нужна, если нет смысла экономить доли секунды.
Есть замечание по использованию CurrentRegion - это использованная область вокруг определённой ячейки, поэтому что А1, что А2, что С27 - в данном коде результат один, не сбивайте себя с толку
и в общем шапку нет смысла обрабатывать, ну да ладно. Внесите в неё несоответствие - и она появится в отчётах

И да, можно сэкономить на алгоритме, обойтись без второго словаря - сразу как не нашли ключ из второго листа в первом словаре - писать эту строку во второй результирующий масссив. Что-то сразу недопёр... Позже может допишу.
1
ZatX
3 / 3 / 1
Регистрация: 15.05.2017
Сообщений: 48
12.12.2017, 21:25  [ТС] 5
О, Благодарю! По CurrentRegion принято ) Просто только вот столкнулся с словарём, мои первые потуги.
0
Hugo121
6508 / 2556 / 459
Регистрация: 19.10.2012
Сообщений: 7,672
12.12.2017, 21:35 6
Вот:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
Option Explicit
 
Sub compare2()
    Dim a, b, c, d, t$, i&, ii&, x&, k
    Dim Dic1 As Object
 
    Application.ScreenUpdating = False
 
    '1.
 
    a = Sheets(1).[a1].CurrentRegion.Value
    b = Sheets(2).[a1].CurrentRegion.Value
 
    '2.
    ReDim c(1 To UBound(a), 1 To UBound(a, 2))
    ReDim d(1 To UBound(b), 1 To UBound(b, 2))
 
    '3.
    Set Dic1 = CreateObject("Scripting.Dictionary")
 
    With Dic1
        For i = 1 To UBound(a)
            t = a(i, 1) & "|" & a(i, 3)
            .Item(t) = i
        Next
 
        '4.
        For i = 1 To UBound(b)
            t = b(i, 1) & "|" & b(i, 3)
 
            If .exists(t) Then
                .Item(t) = 0
            Else
                ii = ii + 1
                For x = 1 To UBound(b, 2)
                    d(ii, x) = b(i, x)
                Next
            End If
        Next
 
        ii = 0
        For Each k In .keys
            If .Item(k) <> 0 Then
                i = .Item(k): ii = ii + 1
 
                For x = 1 To UBound(a, 2)
                    c(ii, x) = a(i, x)
                Next
            End If
        Next
    End With
 
    '5.
    With Worksheets.Add(After:=Sheets(Sheets.Count))
        .Name = "Разница" & Sheets.Count
        .[a2].Resize(ii, 3) = c
        .[e2].Resize(ii, 3) = d
    End With
 
    Application.ScreenUpdating = True
 
End Sub
1
ZatX
3 / 3 / 1
Регистрация: 15.05.2017
Сообщений: 48
12.12.2017, 21:41  [ТС] 7
Дело мастера боится) Как-то так я себе это и представлял... Спасибо Вам ОгромноеHugo121, картинка начинает складываться)
0
Hugo121
6508 / 2556 / 459
Регистрация: 19.10.2012
Сообщений: 7,672
12.12.2017, 21:53 8
Лучший ответ Сообщение было отмечено ZatX как решение

Решение

Упс, есть там одна ошибка при выгрузке - нужно разные ii иметь! Важно!

Добавлено через 5 минут
Исправил:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
Option Explicit
 
Sub compare2()
    Dim a, b, c, d, t$, i&, ii&, iii&, x&, k
    Dim Dic1 As Object
 
    Application.ScreenUpdating = False
 
    '1.
 
    a = Sheets(1).[a1].CurrentRegion.Value
    b = Sheets(2).[a1].CurrentRegion.Value
 
    '2.
    ReDim c(1 To UBound(a), 1 To UBound(a, 2))
    ReDim d(1 To UBound(b), 1 To UBound(b, 2))
 
    '3.
    Set Dic1 = CreateObject("Scripting.Dictionary")
 
    With Dic1
        For i = 1 To UBound(a)
            t = a(i, 1) & "|" & a(i, 3)
            .Item(t) = i
        Next
 
        '4.
        For i = 1 To UBound(b)
            t = b(i, 1) & "|" & b(i, 3)
 
            If .exists(t) Then
                .Item(t) = 0
            Else
                iii = iii + 1
                For x = 1 To UBound(b, 2)
                    d(iii, x) = b(i, x)
                Next
            End If
        Next
 
        
        For Each k In .keys
            If .Item(k) <> 0 Then
                i = .Item(k): ii = ii + 1
 
                For x = 1 To UBound(a, 2)
                    c(ii, x) = a(i, x)
                Next
            End If
        Next
    End With
 
    '5.
    With Worksheets.Add(After:=Sheets(Sheets.Count))
        .Name = "Разница" & Sheets.Count
        .[a2].Resize(ii, 3) = c
        .[e2].Resize(iii, 3) = d
    End With
 
    Application.ScreenUpdating = True
 
End Sub
Логика простая - сперва запоминаем в словаре ключи с одного лисста с их позицией в массиве, затем циклом по данным второго листа проверяем наличие ключа в словаре - если есть, то обнуляем позицию, если нет - то сразу копируем в один итоговый массив.
Далее циклом по словарю все, у кого осталась позиция, копируем в другой итоговый массив.
1
ZatX
3 / 3 / 1
Регистрация: 15.05.2017
Сообщений: 48
12.12.2017, 21:58  [ТС] 9
В данном примере всё выгружает корректно.
Вы имеете ввиду в "пятом элементе" кода?)
Ааа .. понял, Благодарю
0
Hugo121
6508 / 2556 / 459
Регистрация: 19.10.2012
Сообщений: 7,672
12.12.2017, 22:00 10
Выгружало оба массива по одной переменной "размера", в примере по факту оба массива одинаковые получались, но вообще это частный случай, они будут разными!
0
ZatX
3 / 3 / 1
Регистрация: 15.05.2017
Сообщений: 48
12.12.2017, 22:11  [ТС] 11
Спасибо и ещё раз за пояснения Hugo121, , логику я понял. Буду дальше бороздить просторы VBA)
0
12.12.2017, 22:11
Answers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
12.12.2017, 22:11

Заказываю контрольные, курсовые, дипломные и любые другие студенческие работы здесь.

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

Сравнение нескольких колонок с данными в Exel с выводом результата на другой лист
Доброго времени суток! Помогите, пожалуста с решением следующей задачи (всё равно будет это макрос...

Поиск строки и перенос двух соответствующих ей ячеек на другой лист
Подскажите пожалуйста каким образом реализовать вот такую вот скромную задачку. есть таблица в ней...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
11
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2020, vBulletin Solutions, Inc.