Задача: Есть два столбика с данными, и мне надо чтобы в третьем столбике появились данные с 1 и 2 которые не пересикались т.е выделить уникальные значения с двух столбцов. .
1 столбик: Москва | Братск | Иркутск | Москва | Омск | Чита | Омск | Воронеж | 2 столбик: Омск | Москва | СПБ | Казань | Иркутск | Новосибирск | Калининград | Томск | 3 столбик: Братск | Чита | СПБ | Казань | Новосибирск | Калнинград | Томск | Воронеж [moder]Приложите файл с примером. Уберите рекламу из подписи. Это нарушение Правил форума. Исправлено[/moder]
Добрый день. Подскажите как можно реализовать.
Задача: Есть два столбика с данными, и мне надо чтобы в третьем столбике появились данные с 1 и 2 которые не пересикались т.е выделить уникальные значения с двух столбцов. .
1 столбик: Москва | Братск | Иркутск | Москва | Омск | Чита | Омск | Воронеж | 2 столбик: Омск | Москва | СПБ | Казань | Иркутск | Новосибирск | Калининград | Томск | 3 столбик: Братск | Чита | СПБ | Казань | Новосибирск | Калнинград | Томск | Воронеж [moder]Приложите файл с примером. Уберите рекламу из подписи. Это нарушение Правил форума. Исправлено[/moder]ShuteRR
For i = 2 To UBound(arrSrc) If WorksheetFunction.CountIf(Columns("B"), arrSrc(i, 1)) = 0 Then clRes.Add Item:=arrSrc(i, 1), Key:=arrSrc(i, 1) End If Next
For i = 2 To UBound(arrSrc) If WorksheetFunction.CountIf(Columns("A"), arrSrc(i, 1)) = 0 Then clRes.Add Item:=arrSrc(i, 1), Key:=arrSrc(i, 1) End If Next
On Error GoTo 0
ReDim arrRes(1 To clRes.Count, 1 To 1) For i = 1 To clRes.Count arrRes(i, 1) = clRes(i) Next
For i = 2 To UBound(arrSrc) If WorksheetFunction.CountIf(Columns("B"), arrSrc(i, 1)) = 0 Then clRes.Add Item:=arrSrc(i, 1), Key:=arrSrc(i, 1) End If Next
For i = 2 To UBound(arrSrc) If WorksheetFunction.CountIf(Columns("A"), arrSrc(i, 1)) = 0 Then clRes.Add Item:=arrSrc(i, 1), Key:=arrSrc(i, 1) End If Next
On Error GoTo 0
ReDim arrRes(1 To clRes.Count, 1 To 1) For i = 1 To clRes.Count arrRes(i, 1) = clRes(i) Next
'(если только это уже не было проделано ранее, то) 'Перед запуском в редакторе VB в меню Tools\References установить ссылку (включить галку) 'на библиотеку "Microsoft ActiveX Data Objects ... Library", где ... - номер версии. 'Можно выбрать любой максимальный (6.0, 2.8, 2.5...) из того, что установлено на компьютере.
Dim cnn As New ADODB.Connection Dim rst As New ADODB.Recordset
rst.Open _ "SELECT F1 FROM (" & _ "SELECT F1 FROM [Лист1$A2:B1000] UNION ALL " & _ "SELECT F2 FROM [Лист1$A2:B1000]" & _ ") GROUP BY F1 HAVING Count(*) = 1" _ , cnn
[Лист1!C2].CopyFromRecordset rst rst.Close
Set rst = Nothing Set cnn = Nothing End Sub
[/vba]
Тоже поучаствую макросом - ADO+SQL: [vba]
Код
Sub selectData()
'(если только это уже не было проделано ранее, то) 'Перед запуском в редакторе VB в меню Tools\References установить ссылку (включить галку) 'на библиотеку "Microsoft ActiveX Data Objects ... Library", где ... - номер версии. 'Можно выбрать любой максимальный (6.0, 2.8, 2.5...) из того, что установлено на компьютере.
Dim cnn As New ADODB.Connection Dim rst As New ADODB.Recordset
rst.Open _ "SELECT F1 FROM (" & _ "SELECT F1 FROM [Лист1$A2:B1000] UNION ALL " & _ "SELECT F2 FROM [Лист1$A2:B1000]" & _ ") GROUP BY F1 HAVING Count(*) = 1" _ , cnn
Sub test() Dim z, z1, j&, i&, m&: z = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).Value ReDim z1(1 To UBound(z) * 2, 1 To 1) With CreateObject("scripting.dictionary"): .CompareMode = 1 For j = 1 To 2 For i = 1 To UBound(z): .Item(z(i, j)) = .Item(z(i, j)) + 1: Next i, j For j = 1 To 2 For i = 1 To UBound(z) If .Item(z(i, j)) = 1 Then m = m + 1: z1(m, 1) = z(i, j) Next i, j Range("C2").Resize(m, 1).Value = z1 End With End Sub
[/vba]
ShuteRR, вариант макроса,кнопки test и очистка
[vba]
Код
Sub test() Dim z, z1, j&, i&, m&: z = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).Value ReDim z1(1 To UBound(z) * 2, 1 To 1) With CreateObject("scripting.dictionary"): .CompareMode = 1 For j = 1 To 2 For i = 1 To UBound(z): .Item(z(i, j)) = .Item(z(i, j)) + 1: Next i, j For j = 1 To 2 For i = 1 To UBound(z) If .Item(z(i, j)) = 1 Then m = m + 1: z1(m, 1) = z(i, j) Next i, j Range("C2").Resize(m, 1).Value = z1 End With End Sub