VBA находит дубликаты в выбранных ячейках и подсчитывает их
Я прочитал много сообщений на этом форуме о моей проблеме, но не могу найти решения. У меня есть таблица с разным количеством ячеек с повторяющимся значением. Я хотел бы подсчитать дубликаты и показать в других столбцах.
Исходная таблица, в которой я отмечаю несколько ячеек:
Я хотел бы получить такой вывод
У A есть часть кода, но что бы я ни выбрал, он считает последнюю ячейку
Dim rng, rngTarget, rngTargetName As Range
Set rngTarget = Range("D7")
Set items = CreateObject("Scripting.Dictionary")
For Each rng In Selection
If Not items.exists(rng.Value) Then
items.Add rng.Value, 1
rngTarget.Value = items(rng.Value)
rngTargetName = rng
Else
items(rng.Value) = items(rng.Value) + 1
rngTarget.Value = items(rng.Value)
rngTargetName = rng
End If
Next
Что мне не хватает?
Ответы 2
Сначала введите это в стандартный модуль:
Public Function unikue(rng As Range)
Dim arr, c As Collection, r As Range
Dim nCall As Long, nColl As Long
Dim i As Long
Set c = New Collection
nCall = Application.Caller.Count
On Error Resume Next
For Each r In rng
If r.Value <> "" Then
c.Add r.Text, CStr(r.Text)
End If
Next r
On Error GoTo 0
nColl = c.Count
If nCall > nColl Then
ReDim arr(1 To nCall, 1 To 1)
For i = 1 To nCall
arr(i, 1) = ""
Next i
Else
ReDim arr(1 To nColl, 1 To 1)
End If
For i = 1 To nColl
arr(i, 1) = c.Item(i)
Next i
unikue = arr
End Function
Приведенный выше UDF() вернет список уникальных непустых элементов в блоке ячеек.
Затем в наборе ячеек в столбце, скажем, F, начиная с F5, ввод массива:
=unikue(A1:D3)
В G5 введите:
=COUNTIF($A$1:$D$3,F5)
и скопируйте вниз:
В Excel 365 нет решения без VBA.
Спасибо Гэри за помощь, но... я завершил свою версию кода и теперь работает как положено - я могу выбрать несколько ячеек и подсчитать дубликаты.
Мой рабочий код:
Dim rng As Range
Dim var As Variant
Dim i As Integer
i = 0
Set D = CreateObject("Scripting.Dictionary")
For Each rng In Selection
If rng <> "" Then
If D.exists(rng.Value) Then
D(rng.Value) = D(rng.Value) + 1
Else
D.Add rng.Value, 1
End If
End If
Next
For Each var In D.Keys
Range("C" & (i + 18)) = var
Range("E" & (i + 18)) = D(var)
i = i + 1
Next
Set D = Nothing