Есть задача: Сравнить данные на двух листах, по первому столбцу. Строки которые, не совпали нужно вывести на отдельный лист. Метод построчного перебора данных в цикле отпадает, т.к. строк несколько тысяч. Пробовал решить с помощью массивов, но в этом случае не выходит сравнить элементы массивов именно на неравенство, работает только со знаком "=". Наткнулся на просторах рунета на такой код:
Скрытый текст
Код
Option Explicit
Option Base 1
Function ArraysDifference(primArray As Variant, secondArray As Variant) As Variant
Dim newItems() As String 'конечный массив
Dim item As Variant 'текущий элемент
Dim tempItems As New Collection 'временная коллекция
Dim count As Integer 'счётчик элементов
'заполняем коллекцию элементами первичного массива
For Each item In primArray
tempItems.Add item, item
Next item
'проходим по второму массиву и пытаемся добавить его элементы в коллекцию;
'если такой элемент уже добавлен в первом цикле, генерируется ошибка;
'если ошибки не произошло, добавляем новый элемент в конечный массив
count = 0
For Each item In secondArray
On Error Resume Next
tempItems.Add item, item
If Err = 0 Then
count = count + 1
ReDim Preserve newItems(count)
newItems(count) = item
End If
On Error GoTo 0
Next item
ArraysDifference = newItems
End Function
Sub TestArrayDifference()
Dim array1, array2 As Variant
Dim newEmploy, escEmploy As Variant
'сотрудники в начале недели
array1 = Array("Дима", "Вася", "Петя", "Костя", "Паша")
'сотрудники в конце недели
array2 = Array("Лёха", "Игорь", "Петя", "Костя", "Боря")
'новые сотрудники
newEmploy = ArraysDifference(array1, array2)
'выбывшие сотрудники
escEmploy = ArraysDifference(array2, array1)
End Sub
Пример работает, но при попытке допилить макрос с массивами под свои условия, столкнулся с ошибкой несоответствия типов данных:
Скрытый текст
Код
Sub TestArrayDifference()
Dim array1, array2 As Variant
Dim result1, result2 As Variant
Dim arr, arrSec
With Workbooks("test.xlsm").Worksheets("Лист1")
array1 = .Range("B1", .Cells(.Rows.count, "A").End(xlUp)).Value
End With
With Workbooks("test.xlsm").Worksheets("Лист2")
array2 = .Range("B1", .Cells(.Rows.count, "A").End(xlUp)).Value
End With
result1 = ArraysDifference(array1, array2)
'result2 = ArraysDifference(array2, array1)
With Workbooks("test.xlsm").Worksheets("разность").Cells(1, 1)
.Value = result1
End With
End Sub
Подсвечивается строка функции:
Код
tempItems.Add item, item
с Run-time error 13 type mismatch
Файл с примером в аттачменте. Первые два листа с данными, третий лист с результатом. Помогите, пожалуйста, разобраться с решением задачи.
Sub TestArrayDifference()
Dim array1, array2 As Variant
Dim newEmploy, escEmploy As Variant
array1 = Array(1, 2, 3, 4)
array2 = Array(5, 6, 3, 4)
newEmploy = ArraysDifference(array1, array2)
escEmploy = ArraysDifference(array2, array1)
End Sub
Function DiffArrays(a, b)
Dim I&, J&, N&, c()
On Error Resume Next
With CreateObject("Scripting.Dictionary")
For I = LBound(a) To UBound(a)
For J = LBound(a, 2) To UBound(a, 2)
iTemp = .item(a(I, J))
Next
Next
For I = LBound(b) To UBound(b)
For J = LBound(b, 2) To UBound(b, 2)
If Not .Exists(b(I, J)) Then
ReDim Preserve c(N)
c(N) = b(I, J)
N = N + 1
End If
Next
Next
End With
DiffArrays = Application.Transpose(c)
End Function
Sub TestArrayDifference()
Dim array1, array2 As Variant
Dim result1, result2 As Variant
Dim arr, arrSec
With Workbooks("test.xlsm").Worksheets("Лист1")
array1 = .Range("B1", .Cells(.Rows.count, "A").End(xlUp)).Value
End With
With Workbooks("test.xlsm").Worksheets("Лист2")
array2 = .Range("B1", .Cells(.Rows.count, "A").End(xlUp)).Value
End With
result1 = DiffArrays(array1, array2)
With Workbooks("test.xlsm").Worksheets("разность")
.Cells(1, 1).Resize(UBound(result1), 1) = result1
End With
End Sub
Согласие есть продукт при полном непротивлении сторон
Function ArraysDifference(primArray As Variant, secondArray As Variant) As Variant
Dim newItems() As String
Dim item As Variant
Dim tempItems As New Collection
Dim count As Integer
For Each item In primArray
tempItems.Add item, CStr(item)
Next item
count = 0
For Each item In secondArray
On Error Resume Next
tempItems.Add item, CStr(item)
If Err = 0 Then
count = count + 1
ReDim Preserve newItems(count)
newItems(count) = item
End If
On Error GoTo 0
Next item
ArraysDifference = newItems
End Function
Sub TestArrayDifference()
Dim array1, array2 As Variant
Dim newEmploy, escEmploy As Variant
Dim arr, arrSec
'?????????? ? ?????? ??????
With Worksheets("Лист1")
array1 = .Range("A1", .Cells(.Rows.count, "A").End(xlUp)).Value
End With
'?????????? ? ????? ??????
With Worksheets("Лист2")
array2 = .Range("A1", .Cells(.Rows.count, "A").End(xlUp)).Value
End With
newEmploy = ArraysDifference(array1, array2)
'???????? ??????????
escEmploy = ArraysDifference(array2, array1)
Worksheets("разность").Cells(1, 1).Resize(UBound(escEmploy)) = Application.Transpose(escEmploy)
End Sub
Hugo написал: - а кроме того нет такого файла, всех трёх листов, как следствие непонятно что вообще с чем сравниваете... Ну а ошибку я назвал.
Ну естественно, что там ничего этого нет - код с другого форума, написан более 10 лет назад другим человеком, под другие задачи. Я привел его без изменений, ту часть которую я изменил привел блоком кода ниже в этом же сообщении.
Sanja, Макрос погонял: на лист с результатом копируется столбец "B" с листа "Лист2". Возможно, я не совсем ясно изложил задачу в первом посте, извиняюсь. По идее должны сравниваться ячейки столбцов "A" с листов "Лист1" и "Лист2" - НЕсовпавшие строки должны отобразиться на листе "разность". Столбцы "B" не сравниваются, но на листе с результатом должны быть строки полностью - ячейки столбца "A" и столбца "B".
P.S. Если использовать result2, то выгружает почти правильный результат - почему-то идёт вперемежку столбец "A" со столбцом "B", но с этим, впринципе, жить можно. Еще раз, Спасибо!
Hostyle написал #1: Пробовал решить с помощью массивов, но в этом случае не выходит сравнить элементы массивов именно на неравенство
Скрытый текст
Код
Option Explicit
Option Base 1
Sub РазностьМассивов()
Dim Arr1(), Arr2(), OutArr() As String, X As String, R
Dim R1() As Long, R2() As Long, N1 As Long, N2 As Long, M1 As Long, M2 As Long
Dim K1 As Long, K2 As Long, K As Long
Arr1 = Sheets("Лист1").Range("A1").CurrentRegion.Value
Arr2 = Sheets("Лист2").Range("A1").CurrentRegion.Value
N1 = UBound(Arr1): N2 = UBound(Arr2)
ReDim R1(N1), R2(N2)
For K1 = 1 To N1: R1(K1) = K1: Next
For K2 = 1 To N2: R2(K2) = K2: Next
M1 = N1: M2 = N2
For K1 = 1 To N1
X = Arr1(R1(K1), 1)
For K2 = 1 To N2
If R2(K2) Then
If CStr(Arr2(R2(K2), 1)) = X Then R1(K1) = 0: R2(K2) = 0: M1 = M1 - 1: M2 = M2 - 1: Exit For
End If
Next
Next
ReDim OutArr(M1 + M2, 2)
For Each R In R1
If R Then K = K + 1: OutArr(K, 1) = Arr1(R, 1): OutArr(K, 2) = Arr1(R, 2)
Next
For Each R In R2
If R Then K = K + 1: OutArr(K, 1) = Arr2(R, 1): OutArr(K, 2) = Arr2(R, 2)
Next
With Sheets("разность")
.Range("A:B").ClearContents
.Range("A1:B1").Resize(M1 + M2).Value = OutArr
End With
End Sub