Вы можете попробовать этот метод. Он использует определяемый пользователем класс, чтобы помочь в сборе уникальных предметов во втором столбце.
Код в модулях Regular и Class использует тот факт, что при попытке добавить члена в коллекцию с тем же ключом, что и у существующего члена, будет сгенерирована ошибка 457 .
Вы можете увидеть в коде, где вносить изменения, чтобы учесть различия в вашей рабочей таблице и диапазонах для источника (Src) и результатов (Res).
Вы должны переименовать модуль класса cConBy . После того, как вы Insert Class Module , F4 открывает окно свойств. Измените Name параметра там.
Модуль класса
Option Explicit
Private pConBy As String
Private pProd As String
Private pProds As Collection
Private Sub Class_Initialize()
Set pProds = New Collection
End Sub
Public Property Get ConBy() As String
ConBy = pConBy
End Property
Public Property Let ConBy(Value As String)
pConBy = Value
End Property
Public Property Get Prod() As String
Prod = pProd
End Property
Public Property Let Prod(Value As String)
pProd = Value
End Property
Public Function AddProd(Value As String)
On Error Resume Next
pProds.Add Value, CStr(Value)
On Error GoTo 0
End Function
Public Property Get Prods() As Collection
Set Prods = pProds
End Property
Обычный модуль
Option Explicit
Sub UniqueConBy()
Dim cCB As cConBy, colCB As Collection
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes() As Variant
Dim I As Long, J As Long, K As Long
Dim lRowCount As Long
'Source and results location
Set wsSrc = Worksheets("Sheet1")
Set wsRes = Worksheets("Sheet1")
Set rRes = wsRes.Cells(1, 5)
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=2)
End With
'Collect and consolidate the data
Set colCB = New Collection
On Error Resume Next
For I = 2 To UBound(vSrc, 1)
Set cCB = New cConBy
With cCB
.ConBy = vSrc(I, 1)
.Prod = vSrc(I, 2)
.AddProd .Prod
lRowCount = lRowCount + 1
colCB.Add cCB, CStr(.ConBy)
Select Case Err.Number
Case 457
With colCB(CStr(.ConBy))
lRowCount = lRowCount - .Prods.Count - 1
.AddProd cCB.Prod
lRowCount = lRowCount + .Prods.Count
End With
Err.Clear
Case Is <> 0
MsgBox "Error: " & Err.Number & vbTab & Err.Description
Stop
End Select
End With
Next I
On Error GoTo 0
'Create results array
ReDim vRes(0 To lRowCount, 1 To 2)
'column labels
For I = 1 To UBound(vRes, 2)
vRes(0, I) = vSrc(1, I)
Next I
'populate the array
For I = 1 To colCB.Count
With colCB(I)
K = K + 1
vRes(K, 1) = .ConBy
vRes(K, 2) = .Prods(1)
For J = 2 To .Prods.Count
K = K + 1
vRes(K, 2) = .Prods(J)
Next J
End With
Next I
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
End Sub
РЕДАКТИРОВАТЬ:
Альтернативный метод, который приближается к тому, что вы хотите, но дает немного другой результат, заключается в простом использовании параметра «Удалить дубликаты» на вкладке «Лента данных» / «Инструменты данных». Вы должны выбрать оба столбца A и B.
Убедитесь, что ваши данные отсортированы перед применением этого метода (сортировка не будет необходимости с использованием метода VBA).
С вашими опубликованными данными результаты будут выглядеть так:
Вы можете использовать условное форматирование, чтобы исключить повторяющиеся записи в столбце A. Например: используйте формулу = $ A2 = $ A1 и отформатируйте цвет текста так, чтобы он совпадал с цветом фона. Ботаник.По значению все равно будет там, но не будет виден.
