Выборка и подсчет уникальных значений

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Выборка и подсчет уникальных значений (Макросы/Sub)

Raid

Дата: Среда, 28.08.2019, 22:34 | Сообщение № 1

Группа: Пользователи

Ранг: Новичок

Сообщений: 31

Репутация: 0 ±

Замечаний: 0% ±

Excel 365

Уважаемые знатоки, пользовался гуглом, поиском по форуму - однозначный ответ на свой вопрос не нашел.
Задача следующая - есть массив фамилий повоторяющихся, нужно вывести частоту встречаемости каждой на отдельный лист.
Т.е. что бы это выглядело следующим образом:
Шацкая - 8
Артеменко - 5
Клименко - 10
......
......

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

К сообщению приложен файл: 8341266.xlsm (66.0 Kb)

Ответить

gling

Дата: Среда, 28.08.2019, 23:04 | Сообщение № 2

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2519

Репутация: 674 ±

Замечаний: 0% ±

2010

Здравствуйте.

Цитата Raid, 28.08.2019 в 22:34, в сообщении № 1 ()

Задача следующая

Если правильно понял, то задача1 - из массива с фамилиями составить список всех фамилий. Задача 2 - против каждой фамилии прописать сколько раз эта фамилия встречается в массиве. Или уж есть список фамилий которые нужно посчитать? На соседнем листе я его не увидел. Пр наличии списка посчитать можно просто

Код

=СЧЁТЕСЛИ(График!$A$1:$AD$14;A1)

Сложнее из массива выбрать все фамилии и составить список.

ЯД-41001506838083

Ответить

Raid

Дата: Четверг, 29.08.2019, 08:01 | Сообщение № 3

Группа: Пользователи

Ранг: Новичок

Сообщений: 31

Репутация: 0 ±

Замечаний: 0% ±

Excel 365

Спасибо за ответ.
Списка уникальных фамилий нет...
И, из чувства к прекрастному, если это возможно решить задачу в VBA

Ответить

Pelena

Дата: Четверг, 29.08.2019, 19:11 | Сообщение № 4

Группа: Админы

Ранг: Местный житель

Сообщений: 19174

Репутация: 4413 ±

Замечаний: ±

Excel 365 & Mac Excel

[vba]

Код

Sub CountUniqueValues()
    Dim oDic As Object, rng As Range
    Set oDic = CreateObject("Scripting.Dictionary")
    For Each rng In Sheets("График").Range("A1").CurrentRegion
        If rng.Value <> "" Then
            If oDic.Exists(rng.Value) Then
                oDic(rng.Value) = oDic(rng.Value) + 1
            Else
                oDic(rng.Value) = 1
            End If
        End If
    Next rng
    With Sheets("Статистика")
        .UsedRange.ClearContents
        .Range("A1").Resize(oDic.Count) = Application.Transpose(oDic.Keys)
        .Range("B1").Resize(oDic.Count) = Application.Transpose(oDic.Items)
    End With
End Sub

[/vba]

К сообщению приложен файл: 4977295.xlsm (70.4 Kb)

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816

Ответить

Raid

Дата: Четверг, 29.08.2019, 20:32 | Сообщение № 5

Группа: Пользователи

Ранг: Новичок

Сообщений: 31

Репутация: 0 ±

Замечаний: 0% ±

Excel 365

Pelena, спасибо огромное, очень красиво, и функционально !!!
Очень, очень спасибо!

Ответить

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Выборка и подсчет уникальных значений (Макросы/Sub)

Страница 1 из 1
1