Количество уникальных значений в столбце excel vba

 

Hellmaster

Пользователь

Сообщений: 208
Регистрация: 26.03.2019

#1

09.10.2019 10:57:28

Добрый день.
Имеется столбец с названиями. Как при помощи макроса посчитать количество уникальных значений в столбце?
Пытался сделать циклом, но ничего не вышло. Неудавшийся цикл ниже, файл во вложении.

Код
Sub as()
Dim a As Long
Dim b As Long
Dim lastrowdata as long
Dim ch As Integer
lastrowdata= Cells(Rows.count, 1).End(xlUp).Row
ch = 0
For b = 2 To a
  For a = 2 To lastrowData
    If b <> a And Cells(a, 4) <> Cells(b, 4) Then ch = ch + 1
  Next
Next
Cells(lastrowData + 1, 4).Value = ch
End sub

Прикрепленные файлы

  • Лист Microsoft Excel.xlsx (8.24 КБ)

 

IKor

Пользователь

Сообщений: 1167
Регистрация: 27.09.2017

Знакома ли Вам эта статья?

Подсчет количества уникальных значений

Если Вы настаиваете на решении при помощи макросов, то попробуйте реализовать на VBA логику работы формул, представленных в статье.

 

Jack Famous

Пользователь

Сообщений: 10852
Регистрация: 07.11.2014

OS: Win 8.1 Корп. x64 | Excel 2016 x64: | Browser: Chrome

#3

09.10.2019 11:13:27

Hellmaster, здравствуйте!

Нестареющая классика. Работает в выделенном диапазоне

Цитата
IKor: попробуйте реализовать на VBA логику работы формул

словари не имеют конкуренции

на массивах до 100 000 уникальных элементов. Потом начинают проигрывать варианту с предварительной сортировкой  ;)
Реализация же формул в коде будет тупить уже на тысяче…

Прикрепленные файлы

  • СЧЁТУНИК.xlsb (18.63 КБ)

Изменено: Jack Famous09.10.2019 11:28:11
(Добавил Intersect. Теперь можно хоть весь лист выделить — считает очень быстро)

Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄

 

IKor

Пользователь

Сообщений: 1167
Регистрация: 27.09.2017

Offtopic:
— Порядок кипячения воды в домашних условиях: 1. Налить воду в чайник; 2. поставить чайник на плиту; 3 зажечь газ
— Если вода в чайнике уже есть и газ горит: то следует вылить воду из чайника, выключить газ — а для этих начальных условий решение задачи приведено выше

 

IKor, спасибо за статью, возьму на вооружение.
Jack Famous,  спасибо за макрос. У меня выдает ошибку user defined type not defined

 

Jack Famous

Пользователь

Сообщений: 10852
Регистрация: 07.11.2014

OS: Win 8.1 Корп. x64 | Excel 2016 x64: | Browser: Chrome

#6

09.10.2019 12:24:34

IKor, я не понял вашей аллегории (применительно к данному вопросу)
99% всех задач (разумеется, про макросы) связанных с уникальными значениями решается словарями — это самое простое и эффективное одновременно. Исключений практически нет… Да — есть коллекции, для которых не нужно подключать библу, но в

холиваре

по сравнению эффективности и универсальности между ними я на стороне словарей.

Цитата
Hellmaster: выдает ошибку

в файле я подключил нужную библиотеку — советую в вашем также сделать. Ну или использовать

позднее связывание

. Будет медленнее, но разницу вы вряд ли заметите:
    1. замените dic As New Dictionary на dic As Object
    2. добавьте (в строку № 8 например)  Set dic = CreateObject(«Scripting.Dictionary»)

Изменено: Jack Famous09.10.2019 12:33:12

Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄

 

Jack Famous, спасибо. все работает

 

Jack Famous

Пользователь

Сообщений: 10852
Регистрация: 07.11.2014

OS: Win 8.1 Корп. x64 | Excel 2016 x64: | Browser: Chrome

Hellmaster, пользуйтесь на здоровье и обязательно посмотрите ссылки  ;)

UPD:

Разместил

тут

более универсальный макрос-отчёт

Изменено: Jack Famous09.10.2019 16:00:37

Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄

 

IKor

Пользователь

Сообщений: 1167
Регистрация: 27.09.2017

#9

10.10.2019 10:35:01

Цитата
Jack Famous написал:
я не понял вашей аллегории

Для меня макросы — темный лес, на который я смотрю в лучшем случае с опушки…
Поэтому когда другие люди пытаются с их помощью решить задачи, для которых известно решение формулами, то я рекомендую попробовать сначала более простое в реализации решение. Хотя я понимаю, что в конкретных случаях решение с макросами имеет множество преимуществ.
Поэтом прошу мою фразу воспринимать не на свой счет, а применительно к ситуации вообще: принцип поиска решения [формулами] представлен — пользуйтесь; если же его обязательно реализовать в VBA — то я бы пошел таким путем…  

 

Jack Famous

Пользователь

Сообщений: 10852
Регистрация: 07.11.2014

OS: Win 8.1 Корп. x64 | Excel 2016 x64: | Browser: Chrome

#10

10.10.2019 11:08:08

Цитата
IKor: Для меня макросы — темный лес … когда другие люди пытаются с их помощью решить задачи, для которых известно решение формулами, то я рекомендую попробовать сначала более простое в реализации решени

   

1. простота — понятие относительное, не так ли? В данном случае моё готовое решение в 1 щелчок позволяет получить нужную информацию без доп. столбцов с формулами. Вот мне кажется, что именно так намного быстрее и удобнее (а в расширенной версии по ссылке вообще полноценный отчёт получается)
    2. когда создаётся тема и автор явно указывает, какое решение ему нужно, то приоритет, разумеется, за этим решением. Есть, конечно, вероятность, что он просто не знает, что есть другие варианты или, что другой намного лучше. Короче, никто не запрещает давать другие варианты…
Совсем другое дело, когда вы предлагаете вариант «не по теме» при этом критикуя «уместный». И я бы не назвал эту критику обоснованной, потому что так и не понял, что я сделал не так  :D

Считаю, что дополнительные альтернативные варианты редко бывают лишними и ваша ссылка вполне уместна

Изменено: Jack Famous10.10.2019 11:08:34

Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄

 

IKor

Пользователь

Сообщений: 1167
Регистрация: 27.09.2017

#11

10.10.2019 11:25:52

Цитата
Jack Famous написал:
когда вы предлагаете вариант «не по теме» при этом критикуя «уместный».

Пожалуйста, не приписывайте мне действий, которые я не совершал.
Я не предлагал свой вариант — а предложил ознакомиться со статьей из ПРИЕМов до того, как станет понятно займется ли кто-нибудь еще этим вопросом
И уж тем более не критиковал предложенный Вами вариант решения.
А лишь обратил внимание на некоторую схожесть ситуации: вместо прямого пути решения задачи (макросами) к финишу можно добраться, двигаясь по более долгому, но знакомому [мне] пути.
Я еще раз прошу не принимать близко к сердцу мои слова — они относятся к возникшей ситуации!

 

Oleg OK

Пользователь

Сообщений: 13
Регистрация: 04.09.2022

#12

07.02.2023 21:08:46

Jack Famous, Добрый вечер! имеется столбец с значениями с помощью кода найденного на этом прекрасном форуме удалось решить задачку по подсчету уникальных значений.
Следующая задача это найти самое часто встречающееся значение. подскажите пожалуйста как сделать? т.е нужно вернуть «по собственному» (не прошу сделать за меня прошу помочь советом или послать меня туда куда копать =) ) но не очень сложно для понимания.
Так же помогите пожалуйста с следующими вопросами:
1) не могу вернуть 1ое значение из словаря т.е обращаясь Debug.print Dic(0) не получаю ничего
Назначая доп. переменную по принципу S = «по собственному»
Debug.print dic(S) не происходит тоже ничего =(
Ответьте пожалуй на вопрос почему не могу вернуть значение из словаря по итему / ключу ?
2) Так же вопрос все таки где хранятся значения в моем случае в Key или в Item? ( на приложенной картинке почему то и там и там О_о)

Код
Sub dd()
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim dic As Object, rng As Range, ar As Range
Dim x, arr

Set dic = CreateObject("Scripting.Dictionary")
    For Each ar In Range(Cells(3, 1), Cells(LastRow, 1))
    arr = ar
    If Len(arr) Then x = dic(arr)
Next ar
Range("B2") = dic.Count
End Sub

Так же вопрос по этой строке «If Len(arr) Then x = dic(arr)» как я понимаю тут подсчитывается кол-во байтов, и если оно совпадает с значением в словаре, то не записывается. Верно? вопрос что за переменная X и почему ее значение всегда равно ПУСТОТЕ.

Заранее спасибо!

Прикрепленные файлы

  • Библиотека счет значений.xlsm (14.68 КБ)
  • 222.png (18.38 КБ)

Изменено: Oleg OK07.02.2023 21:09:33

 

Ігор Гончаренко

Пользователь

Сообщений: 13746
Регистрация: 01.01.1970

#13

07.02.2023 21:44:08

Цитата
Oleg OK написал:
вопрос что за переменная X

на военной кафедре:
пусть количество танков будет Х… нет, мало пусть будет У
с тояки зрения математики и программирования переменная Х НИЧЕМ не отличается от У

Программисты — это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!

 

Hugo

Пользователь

Сообщений: 23253
Регистрация: 22.12.2012

1) Порядок в словаре не регламентируется, поэтому такой запрос по сути не имеет смысла. Но физически там конечно есть первое значение…
2). keys — ключи, items — значения.

Чтоб найти самое часто встречающееся — можно например записывать в словарь количество повторений ключа, и сразу максимально полученное число запоминать в переменную. Можно с ключём.
Но если таких несколько? Тогда в конце можно пройтись циклом по словарю и всех с таким итемом собрать в массив/коллекцию/лист.

 

Ігор Гончаренко

Пользователь

Сообщений: 13746
Регистрация: 01.01.1970

#15

07.02.2023 22:01:12

Код
Sub dd()
  Dim a, c&, d As Object, r&, rg As Range, m, nm$
  a = Range(Cells(1), Cells(Rows.Count, 1).End(xlUp))
  Set d = CreateObject("Scripting.Dictionary")
  For r = 1 To UBound(a)
    If Len(a(r, 1)) Then
      c = d(a(r, 1)) + 1: d(a(r, 1)) = c
      If c > m Then m = c: nm = a(r, 1)
    End If
  Next
  Range("B2") = nm & " = " & d(nm) & " øò."
  Range("b3").Resize(d.Count, 1) = WorksheetFunction.Transpose(d.items)
  Range("c3").Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
End Sub

Программисты — это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!

 

Oleg OK

Пользователь

Сообщений: 13
Регистрация: 04.09.2022

#16

08.02.2023 08:31:34

Цитата
написал:
акой запрос по сути не имеет смысла. Но физически там конечно есть первое зна

Спасибо улыбнуло)  ;)  Я понимаю что Х от Y и даже от «И краткой» не отличается ничем) Вопрос что она делает в коде выше. Не могу понять мы считаем длину строки и в переменную Х записываем слово которое сейчас в перебираемой ячейке? О_о  а почему Х всегда пустой, как бы я не бегал по нему пошаговым выполнением макроса =(  

Код
If Len(arr) Then x = dic(arr) 

Простите, что докапываюсь «школьными» вопросами.

Справку по лен  и словарю читал / гуглин все равно на голову не налазит все это.

 

Jack Famous

Пользователь

Сообщений: 10852
Регистрация: 07.11.2014

OS: Win 8.1 Корп. x64 | Excel 2016 x64: | Browser: Chrome

#17

08.02.2023 10:14:38

Цитата
Hugo: Порядок в словаре не регламентируется

ошибочное заявление. при получении массивов из коллекций ключей и значений словаря они по индексам соответствтвуют друг-другу и порядку добавления в словарь

Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄

After reading through this and then investigating further, I’ve got one that works better for me than anything I see here:

Array-enter:
(Ctrl+Shift+Enter, and don’t include the curly brackets)

{=SUM(IFERROR(1/COUNTIF(C2:C2080,C2:C2080),0))}

Or in VBA:

MyResult = MyWorksheetObj.Evaluate("=SUM(IFERROR(1/COUNTIF(C2:C2080,C2:C2080),0))")

It works for both numbers and text, it handles blank cells, it handles errors in referenced cells, and it works in VBA. It’s also one of the most compact solutions I’ve seen. Using it in VBA, it apparently automatically handles the need to be an array formula.

Note, the way it handles errors is by simply including them in the count of uniques. For example, if you have two cells returning #DIV/0! and three cells returning #VALUE!, those 5 cells would add 2 to the final count of unique values. If you want errors completely excluded, it would need to be modified for that.

In my tests, this one from Jacob above only works for numbers, not text, and does not handle errors in referenced cells (returns an error if any of the referenced cells returns an error):

=SUM(IF(FREQUENCY(G4:G29,G4:G29)>0,1))

Bati4eli

615 / 15 / 8

Регистрация: 05.05.2012

Сообщений: 221

Записей в блоге: 11

1

Количество уникальных значений по условию

16.04.2013, 12:14. Показов 19049. Ответов 39

Метки нет (Все метки)


Студворк — интернет-сервис помощи студентам

Привет, всем!
Столкнулся со следующей проблемой: требуется подсчитать кол-во уникальных значений в одном столбце, если в соседнем столбце значение удовлетворяет определенному требованию. Желательно решить задачу стандартными средствами эксель (так как оно может и не проще , но быстрее точно).
Написал функцию для этой задачи, но 6000 строк она глотает 30 секунд ..=(

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
Public Enum MTD
    [КОЛИЧЕСТВО_УНИ] = 0
    [МАССИВ_УНИ] = 1
End Enum
Public Function СВОД_УСЛ(Диапазон As Range, Условие As Variant, _
     Диапазон_условия As Range, metod As MTD)
Dim IC As Range
Dim RC As Range
Dim icv As Variant
Dim rcv As Variant
Dim x As Long
Dim y As Long
Dim USL() As Variant
Dim SHT As Boolean
Application.Volatile
x = Диапазон.Row + Диапазон.Rows.Count - 1
y = Диапазон.Parent.UsedRange.Rows.Count
If x > y Then x = y - Диапазон.Row + 1
Set Диапазон = Range(Диапазон.Cells(1), Диапазон.Rows(x).Cells(1))
Set Диапазон_условия = Диапазон.Offset(0, Диапазон_условия.Column - Диапазон.Column)
 
ReDim USL(1 To 1)
For Each IC In Диапазон_условия
    icv = IC.Value
    If LCase(icv) = LCase(Условие) Then
        For Each RC In Диапазон
            rcv = RC.Value
            If rcv <> "" And rcv <> 0 Then
                If RC.Row = IC.Row Then
                    SHT = True
                    For x = 1 To UBound(USL)
                        If USL(x) = rcv Then
                            SHT = False
                        End If
                    Next
                    If SHT Then
                        USL(UBound(USL)) = rcv
                        ReDim Preserve USL(1 To UBound(USL) + 1)
                    End If
                End If
            End If
        Next
    End If
Next
ReDim Preserve USL(1 To UBound(USL) - 1)
Select Case metod
    Case КОЛИЧЕСТВО_УНИ
    СВОД_УСЛ = UBound(USL)
    Case МАССИВ_УНИ
    СВОД_УСЛ = USL()
End Select
End Function



0



1121 / 229 / 36

Регистрация: 15.03.2010

Сообщений: 698

16.04.2013, 13:38

2

Расширенный фильтр не подойдет? Поставить пустое условие и галку на уникальных значениях. Потом посчитать видимые строки, если фильтровать на месте.



0



81 / 24 / 2

Регистрация: 18.01.2013

Сообщений: 74

16.04.2013, 13:48

3

можно так:

=ЕСЛИ(И(СЧЁТЕСЛИ(B:B;B2)=1;C2=$C$1);1;0)

B:B — столбец в котором значение должно быть уникальным
B2 — проверяемое значение
C — столбец «соседний, в котором должно выполняться условие»
$C$1 — условие

протянуть формулу на весь столбец и посчитать получившуюся сумму….



0



KoGG

5590 / 1580 / 406

Регистрация: 23.12.2010

Сообщений: 2,366

Записей в блоге: 1

16.04.2013, 14:18

4

Замени с 23 по 44 строку, будет быстрее:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
For Each IC In Диапазон_условия
    icv = IC.Value
    If LCase(icv) = LCase(Условие) Then
        For Each RC In Диапазон.Rows(IC.row).Cells
            rcv = RC.Value
            If rcv <> "" And rcv <> 0 Then
                SHT = True
                For x = 1 To UBound(USL)
                    If USL(x) = rcv Then
                        SHT = False
                    End If
                Next
                If SHT Then
                    USL(UBound(USL)) = rcv
                    ReDim Preserve USL(1 To UBound(USL) + 1)
                End If
            End If
        Next
    End If
Next



1



Bati4eli

615 / 15 / 8

Регистрация: 05.05.2012

Сообщений: 221

Записей в блоге: 11

16.04.2013, 15:07

 [ТС]

5

Вот я дурак.. я думал, что этот цикл в цикле не особо увеличит время работы!
KoGG, да по идеии нужно сразу адресовать на аналогичную строку в проверяемом диапазоне.

Visual Basic
1
Set RC = Диапазон.Rows(IC.Row).Cells

Единственный вопрос: почему у меня не выводится массив на листе, когда я использую метод в функции «МАССИВ_УНИ» ?



0



KoGG

5590 / 1580 / 406

Регистрация: 23.12.2010

Сообщений: 2,366

Записей в блоге: 1

16.04.2013, 15:38

6

Если диапазон «Диапазон» из одной колонки, то

Visual Basic
1
Set RC = Диапазон.Rows(IC.Row).Cells(1)

Да и RC вовсе не нужна.

Visual Basic
1
rcv = Диапазон.Rows(IC.Row).Cells(1).Value

Добавлено через 21 минуту
А загнав данные в массивы будет еще быстрее.

Кликните здесь для просмотра всего текста

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Public Function СВОД_УСЛ(Диапазон As Range, Условие As Variant, _
     Диапазон_условия As Range, metod As MTD)
Dim i&, j&
Dim Dia_Usl As Variant
Dim Dia As Variant
Dim x As Long
Dim y As Long
Dim USL() As Variant
Dim SHT As Boolean
Application.Volatile
x = Диапазон.row + Диапазон.Rows.Count - 1
y = Диапазон.Parent.UsedRange.Rows.Count
If x > y Then x = y - Диапазон.row + 1
Dia = Range(Диапазон.Cells(1), Диапазон.Rows(x).Cells(1))
Dia_Usl = Диапазон.Offset(0, Диапазон_условия.Column - Диапазон.Column)
ReDim USL(1 To 1)
For i = 1 To UBound(Dia_Usl, 1)
    If LCase(Dia_Usl(i, 1)) = LCase(Условие) Then
        If Dia(i, 1) <> "" And Dia(i, 1) <> 0 Then
            SHT = True
            For x = 1 To UBound(USL)
                If USL(x) = Dia(i, 1) Then
                    SHT = False
                End If
            Next
            If SHT Then
                USL(UBound(USL)) = Dia(i, 1)
                ReDim Preserve USL(1 To UBound(USL) + 1)
            End If
        End If
    End If
Next
ReDim Preserve USL(1 To UBound(USL) - 1)
Select Case metod
    Case КОЛИЧЕСТВО_УНИ
    СВОД_УСЛ = UBound(USL)
    Case МАССИВ_УНИ
    СВОД_УСЛ = USL()
End Select
End Function

Добавлено через 5 минут
Используя параметр «МАССИВ_УНИ» ты получаешь массив.
Вызывая функцию из ячейки листа, ты не можешь весь массив поместить в одну ячейку.
Возможно помогут ввод массива твоих функций в нужный диапазон как формул массива ({}), хотя легче и понятнее будет вызывать функцию из процедуры и в ней же делать вывод на лист итогов работы функции.



0



6875 / 2807 / 533

Регистрация: 19.10.2012

Сообщений: 8,562

16.04.2013, 21:27

7

Если не работать с ячейками — будет ещё раз так в 40 быстрее…
Вообще удивляюсь — как вы все так виртуально коды разбираете…
Судя по описанию — на 6000 строк на словаре/массиве отработает за доли секунды. Но без файла делать…



0



615 / 15 / 8

Регистрация: 05.05.2012

Сообщений: 221

Записей в блоге: 11

17.04.2013, 13:21

 [ТС]

8

Hugo121,

Цитата
Сообщение от Hugo121
Посмотреть сообщение

Если не работать с ячейками — будет ещё раз так в 40 быстрее…

Как можно не работать с ячейками?
Посмотрите, пожалуйста, пример.



0



615 / 15 / 8

Регистрация: 05.05.2012

Сообщений: 221

Записей в блоге: 11

17.04.2013, 13:28

 [ТС]

9

KoGG,
попробовал использовать массив.. и почему то, функция стала работать в разы дольше, чем вариант работы с ячейками .

Посмотрите, пожалуйста, пример из предыдущего сообщения. (Там используется старая функция)



0



Казанский

15136 / 6410 / 1730

Регистрация: 24.09.2011

Сообщений: 9,999

17.04.2013, 15:06

10

Лучше создать функцию, которая вводится в столбец как формула массива и возвращает массив.
При этом в функции достаточно один раз пройти по массивам Диапазон, Диапазон_условия и посчитать уникальные, а потом сформировать выходной массив.
Использовал словарь коллекций

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Public Function СЧЕТ_УСЛ(Диапазон As Range, Условие As Range, Диапазон_условия As Range) As Variant()
Dim q(), w(), x, i&
q = Intersect(Диапазон, Диапазон.Worksheet.UsedRange).Value
w = Intersect(Диапазон_условия, Диапазон_условия.Worksheet.UsedRange).Value
On Error Resume Next
With New Scripting.Dictionary ' ===== Tools - References - Microsoft Scripting Runtime =====
    .CompareMode = TextCompare
    For Each x In w
        i = i + 1
        If Not IsObject(.Item(x)) Then Set .Item(x) = New Collection
        .Item(x).Add 0, q(i, 1)
    Next
    ReDim w(1 To Условие.Count, 1 To 1)
    i = 0
    For Each x In Условие.Value
        i = i + 1
        w(i, 1) = .Item(x).Count
    Next
End With
СЧЕТ_УСЛ = w
End Function

Функцию надо вводить в столбец С4:С282 с помощью Ctrl+Shift+Enter. Расчет занимает доли секунды, результат совпадает с существующим:

Код

=СЧЕТ_УСЛ(ИСТОЧНИК!A:A;A4:A282;ИСТОЧНИК!B:B)



1



5590 / 1580 / 406

Регистрация: 23.12.2010

Сообщений: 2,366

Записей в блоге: 1

17.04.2013, 17:44

11

Кстати, оптимальнее всего в данной задаче вообще убрать функцию, а на листе источник рядом с суммой добавить колонку численность, и по всей колонке проставить 1. В сводной таблице добавить поле колонки численность и она будет суммироваться.



0



5590 / 1580 / 406

Регистрация: 23.12.2010

Сообщений: 2,366

Записей в блоге: 1

17.04.2013, 18:09

12

А вот тестовый пример, где работают три метода.
Тестовая процедура bb
Результаты:
Исправленный оригинал — СВОД_УСЛ время 0,06 сек
Мой вариант с массивами — СВОД_УСЛ2 время 0,02 сек
Вариант Казанского СЧЕТ_УСЛ время 0,11 сек.

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

А еще оптимальнее — смотри выше.



0



5590 / 1580 / 406

Регистрация: 23.12.2010

Сообщений: 2,366

Записей в блоге: 1

17.04.2013, 18:15

13

Офис 2007, Windows 8, процессор Intel(R) Core(TM) i7 CPU 930 @ 2.8 GHz, Оперативка 4 Гб.



0



Bati4eli

615 / 15 / 8

Регистрация: 05.05.2012

Сообщений: 221

Записей в блоге: 11

17.04.2013, 22:37

 [ТС]

14

Цитата
Сообщение от KoGG
Посмотреть сообщение

Кстати, оптимальнее всего в данной задаче вообще убрать функцию, а на листе источник рядом с суммой добавить колонку численность, и по всей колонке проставить 1. В сводной таблице добавить поле колонки численность и она будет суммироваться.

К сожалению в том то и дело, что одной сводной здесь не решишь задачу, так как таким методом мы получим не кол-во уникальных людей по одной профессии, а все платежи совершенные по этой профессии.

Честно говоря извеняюсь за то, что поднял такую панику Я думал, что этот файл придется перекидывать по предприятию (а вы знаете, что макросы включены не у всех и ошибка типа #ИМЯ введет в ступор непродвинутых людей).

Казанский, ваш метод я обязательно завтра испробую.

А так написал тупо макрос, выводящий массив профессий и численность рядом с ними.

Самый последнейший вопрос:
Почему функция

Visual Basic
1
2
3
Function MyFunc() as variant
MyFunc =  array("Арг1","Арг2","Арг3")
End Function

при вводе её в Excel (как массив) у меня отображается только самый первый элемент массива?
Весь день матюкался!



0



Аксима

6076 / 1320 / 195

Регистрация: 12.12.2012

Сообщений: 1,023

17.04.2013, 22:59

15

Цитата
Сообщение от Bati4eli
Посмотреть сообщение

Почему функция

Visual Basic
1
2
3
Function MyFunc() as variant
MyFunc = array("Арг1","Арг2","Арг3")
End Function

при вводе её в Excel (как массив) у меня отображается только самый первый элемент массива?
Весь день матюкался!

Одномерный массив в Excel представляется 1 строкой и несколькими столбцами.

В данном случае вам надо выделить на листе область из 1 строки и 3 столбцов, в строке формул ввести =MyFunc() и нажать клавиши Ctrl+Shift+Enter.
Попробуйте, у вас все получится .



0



615 / 15 / 8

Регистрация: 05.05.2012

Сообщений: 221

Записей в блоге: 11

18.04.2013, 09:35

 [ТС]

16

Aksima,
честно говоря я всю жизнь думал, что массивы строчные (т.е. одномерный массив представлен в виде одной колонки из множества строк). А как представить массив, чтобы он распределялся по строкам, а не столбцам в экселе?

Казанский,
К сожалению ваш вариант, не совсем верно считает. Он видимо подсчитывает кол-во платежей по выбранной профессии, а функция должна высчитывать кол-во уникальных табелей по определенной профессии.



0



Аксима

6076 / 1320 / 195

Регистрация: 12.12.2012

Сообщений: 1,023

18.04.2013, 09:49

17

Цитата
Сообщение от Bati4eli
Посмотреть сообщение

А как представить массив, чтобы он распределялся по строкам, а не столбцам в экселе?

Можете попробовать так:

Visual Basic
1
2
3
Function MyFunc() As Variant
   MyFunc = Application.Transpose(Array("Arg1", "Arg2", "Arg3"))
End Function

С уважением,

Aksima



1



615 / 15 / 8

Регистрация: 05.05.2012

Сообщений: 221

Записей в блоге: 11

18.04.2013, 09:59

 [ТС]

18

Вот для чего транспонирование в экселе нужно =)
Спасибо, большое!



0



15136 / 6410 / 1730

Регистрация: 24.09.2011

Сообщений: 9,999

18.04.2013, 10:01

19

Цитата
Сообщение от Bati4eli
Посмотреть сообщение

ваш вариант, не совсем верно считает

На примере, который Вы привели в сообщении #8, моя функция дает точно такой же результат, как ваша функция — я выводил в другой столбец и сравнивал.
Покажите на конкретных данных, что неверно.



0



615 / 15 / 8

Регистрация: 05.05.2012

Сообщений: 221

Записей в блоге: 11

18.04.2013, 11:20

 [ТС]

20

Казанский,
наверно я не выспался и плюс никогда не пользовался коллекциями, поэтому не совсем врубаюсь в принцип работы вашей функции.
При выводе результата у меня везде получается 152.



0



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

drblasster88

Дата: Суббота, 16.01.2016, 15:21 |
Сообщение № 1

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

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

Сообщений: 18


Репутация:

0

±

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


Excel 2007

Доброго времени суток! Дамы и господа, нужна помощь в составлении макроса для сбора отчетности. Если кто-то сможет помочь — буду очень благодарен.
Прикладываю 2 файла. В первом файле выгрузка данных из программы, она всегда будет одного формата, но с разным количеством значений, во втором файле отчетная форма в которую нужно вывести количественные значения по собранным данным:
-В первом файле в столбце А ищем запись «Решение о приостановлении операций по счетам (НО)», количество найденных записей выводим в отчетную форму в ячейку С3
-В первом файле в столбце А ищем запись «Решение об отмене приостановления операций по счетам (НО)», количество найденных записей выводим в отчетную форму в ячейку F3
-В первом файле в столбце С ищем уникальные записи по маске «BOS1_RPO» и «BOS1_RBN» (считать уникальные значения, т.к. наименования таких записей могут повторяться, а нам нужно считать количество уникальных значений) и их количество выводим в отчетную форму в ячейку D3
-В первом файле в столбце С ищем уникальные записи по маске «PB2_RPO» (считать уникальные значения, т.к. наименования таких записей могут повторяться, а нам нужно считать количество уникальных значений) и их количество выводим в отчетную форму в ячейку E3
— В первом файле в столбце B ищем уникальные значения по маске «29000112» и «29000117» считаем только те, напротив которых в столбце не стоят значения «BOS1_RPO», «PB2_RPO» и «BOS1_RBN», т.е. пустые поля, результат выводим в таблицу в ячейку I3

К сообщению приложен файл:

3592029.xlsm
(12.8 Kb)

 

Ответить

drblasster88

Дата: Суббота, 16.01.2016, 15:31 |
Сообщение № 2

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

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

Сообщений: 18


Репутация:

0

±

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


Excel 2007

Вот файл выгрузки

К сообщению приложен файл:

1436148.xlsm
(98.3 Kb)

 

Ответить

Manyasha

Дата: Воскресенье, 17.01.2016, 00:49 |
Сообщение № 3

Группа: Модераторы

Ранг: Старожил

Сообщений: 2198


Репутация:

898

±

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


Excel 2010, 2016

drblasster88, проверяйте (макрос запускается из файла отчет)
[vba]

Код

Sub report()
    Application.ScreenUpdating = False
    Dim f As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = «Please select a file»: .InitialFileName = ThisWorkbook.Path
        .Filters.Add «Excel», «*.xls;*.xlsx;*.xlsm;*.xlsb», 1: .AllowMultiSelect = False
        If .Show = False Then Exit Sub: If .SelectedItems.Count = 0 Then Exit Sub
        f = .SelectedItems(1)
    End With
    Set shRep = ThisWorkbook.Sheets(1)
    Set openWb = Workbooks.Open(f)
    Set shData = openWb.Sheets(1)
    shRep.Range(«c3») = WorksheetFunction.CountIf(shData.Columns(1), «Решение о приостановлении операций по счетам (НО)»)
    shRep.Range(«f3») = WorksheetFunction.CountIf(shData.Columns(1), «Решение об отмене приостановления операций по счетам (НО)»)
    Set d1 = CreateObject(«Scripting.Dictionary»)
    Set d2 = CreateObject(«Scripting.Dictionary»)
    Set d3 = CreateObject(«Scripting.Dictionary»)
    Dim dataBC
    dataBC = shData.[b1].Resize(shData.UsedRange.Rows.Count, 2)
    For i = 1 To UBound(dataBC)
        If InStr(dataBC(i, 2), «BOS1_RPO») Or InStr(dataBC(i, 2), «BOS1_RBN») Then
            If d1.Exists(dataBC(i, 2)) = False Then d1.Item(dataBC(i, 2)) = i
        ElseIf InStr(dataBC(i, 2), «PB2_RPO») Then
            If d2.Exists(dataBC(i, 2)) = False Then d2.Item(dataBC(i, 2)) = i
        End If
        If (InStr(dataBC(i, 1), «29000112») Or InStr(dataBC(i, 1), «29000117»)) _
            And Trim(dataBC(i, 2)) = «» Then
            If d3.Exists(dataBC(i, 2)) = False Then d3.Item(dataBC(i, 2)) = i
        End If
    Next i
    shRep.Range(«d3») = d1.Count
    shRep.Range(«e3») = d2.Count
    shRep.Range(«i3») = d3.Count
    openWb.Close
    Application.ScreenUpdating = True
End Sub

[/vba]
[p.s.]Выгрузку в xlsb сохранила, чтобы влезло в 100кб[/p.s.]


ЯД: 410013299366744 WM: R193491431804

 

Ответить

drblasster88

Дата: Воскресенье, 17.01.2016, 05:14 |
Сообщение № 4

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

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

Сообщений: 18


Репутация:

0

±

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


Excel 2007

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

Спасибо Вам огромное!!! Очень выручили! Но есть два вопроса:
В первом файле в столбце B ищем уникальные значения по маске «29000112» и «29000117» считаем только те, напротив которых в столбце не стоят значения «BOS1_RPO», «PB2_RPO» и «BOS1_RBN», т.е. пустые поля, результат выводим в таблицу в ячейку I3
По выше указанному условию я вижу в вашем макросе, что вы задали параметр пусто And Trim(dataBC(i, 2)) = «» Then
Но по какой то причине в отчете постоянно стоит «1». Насколько я понял это происходит из за того что для «29000117» кроме вариантов «BOS1_RPO», «PB2_RPO» и «BOS1_RBN» есть еще вариант «Статус: Исполнено». По логике он должен в отчет выводить только количество тех экземпляров «29000117» у которых (i, 2)) = «». Причем в полной выгрузке(я вам предоставлял только ее часть из за большого объема файла) таких экземпляров больше чем один, но в отчете все равно единица. Не подскажете что нужно поменять в коде, что бы в ячейку I3 не выводилось количество экземпляров по «29000117» у которых (i, 2)) = «»???
Так же не совсем понял как получилось что количество «BOS1_RPO» + «BOS1_RBN» больше чем количество «Решение о приостановлении операций по счетам (НО)»), они должны быть равны или меньше. (Это тоже видно по отчету из полной выгрузки)Надеюсь вы не против если я вам на marinamorozova_box@mail.ru его пришлю?

 

Ответить

Manyasha

Дата: Воскресенье, 17.01.2016, 15:06 |
Сообщение № 5

Группа: Модераторы

Ранг: Старожил

Сообщений: 2198


Репутация:

898

±

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


Excel 2010, 2016

drblasster88,
не по Правилам это!
Решать вопросы вне темы разрешается только в разделе Работа/Фриланс.
Либо выкладывайте новый файл сюда, либо просите перенести тему.

По Вашим вопросам (файлы из моего поста):
1. Для строк со значениями «29000112» и «29000117» получается 1, т.к. в Выгрузке есть 1 такая строчка. Там объединенные ячейки, и фактически «Статус: Исполнено» стоит на строчку выше, а в текущей и правда пусто (строчку желтым выделила) :)
Правильно ли я понимаю, что должно быть не 1, а ноль? Т.е в 3-м столбце по текущему счету везде пусто? См. новый файл, код поправила.

По второму пункту:

количество «BOS1_RPO» + «BOS1_RBN» больше чем количество «Решение о приостановлении операций по счетам (НО)»

Не нашла такого…количество «BOS1_RPO» + «BOS1_RBN» = 102, «Решение о приостановлении…» = 105.

Это тоже видно по отчету из полной выгрузки

Покажите кусок, где не правильно считается.
UPD Файл забыла прикрепить!

К сообщению приложен файл:

6314099.rar
(66.8 Kb)


ЯД: 410013299366744 WM: R193491431804

Сообщение отредактировал ManyashaВоскресенье, 17.01.2016, 15:43

 

Ответить

Manyasha

Дата: Воскресенье, 17.01.2016, 16:01 |
Сообщение № 6

Группа: Модераторы

Ранг: Старожил

Сообщений: 2198


Репутация:

898

±

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


Excel 2010, 2016

Кстати, посмотрите примечания в файле отчет. Может я не правильно поняла, что куда вносить?…


ЯД: 410013299366744 WM: R193491431804

 

Ответить

drblasster88

Дата: Воскресенье, 17.01.2016, 16:35 |
Сообщение № 7

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

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

Сообщений: 18


Репутация:

0

±

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


Excel 2007

Уменьшил выгрузку до допустимого объема. Давайте с ней поработаем. Вы все правильно поняли. Данные вставляются куда нужно.
Вот что у меня сейчас
Общая загрузка Приостановления Отмены Не отправлено Справок по приостановлениям
Всего Справка Отказ Всего
ВВБ 164 162 3 9 1

По поводу разности значений в столбце Всего и сумме столбцов Справка и отказ, кажется понял. В Файле причина в самом конце: Там для одного «Решения о приостановлении» два типа ответа «BOS1» и «PB2» из за этого сумма «BOS1» и «PB2» получается больше чем сумма «Решения о приостановлении». Думаю с этим наверно мы ничего не сможем сделать…

А вот по поводу столбца «Не отправлено Справок по приостановлениям» можно ли сделать что-нибудь с объединенной ячейкой? потому что во всех ответах она будет объединена и находиться на той же позиции, различие будет только в том что по 2900012 она будет полностью пустая, а по 2900017 возможны два варианта — полностью пустая и с надписью «Статус: Исполнено», последний вариант в отчет попадать не должен. В выгрузке сделал оба варианта, для удобства я все проблемные варианты поместил внизу, начинайте смотреть после ячейки 2313

 

Ответить

Manyasha

Дата: Воскресенье, 17.01.2016, 17:37 |
Сообщение № 8

Группа: Модераторы

Ранг: Старожил

Сообщений: 2198


Репутация:

898

±

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


Excel 2010, 2016

по 2900017 возможны два варианта — полностью пустая и с надписью «Статус: Исполнено», последний вариант в отчет попадать не должен

дык в последнем моем файле так и есть — попадают в отчет только полностью пустые, Статус исполнено НЕ попадает.

для одного «Решения о приостановлении» два типа ответа

так должно быть?
Может тогда просто посчитать Всего (С3), Справка (D3), а отказ поставить, как C3-D3?

[p.s.]

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

Файл не открывается (расширение является не допустимым), сокрее всего из-за того, что Вы расширение вручную поменяли. Да и к тому же вес 0кб[/p.s.]


ЯД: 410013299366744 WM: R193491431804

 

Ответить

drblasster88

Дата: Воскресенье, 17.01.2016, 18:23 |
Сообщение № 9

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

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

Сообщений: 18


Репутация:

0

±

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


Excel 2007

по 2900017 возможны два варианта — полностью пустая и с надписью «Статус: Исполнено», последний вариант в отчет попадать не должен
Я может что то не так делаю но у меня в отчет падают пустые только по 29000112…пустые по 29000117 в отчет не попадают. Скажите, а можно сделать, что бы в отчете в ячейку К3 помещались в строчку через запятую полные наименования файлов 29000112 и 29000117 по которым эти самые пустые ячейки?

А по поводу отказов….Я что то не сообразил сразу….наверно так и сделаю. Спасибо вам огромное

 

Ответить

drblasster88

Дата: Воскресенье, 17.01.2016, 19:12 |
Сообщение № 10

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

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

Сообщений: 18


Репутация:

0

±

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


Excel 2007

Точнее после того как макрос находит одну ячейку пустую, он ставит цифру 1 и больше ничего в отчет не выводится…А мне хотелось бы что б он писал количество пустых. Наверно это связано с тем что в ячейку I3 он тоже выводит только уникальные значения? Там нужно что бы было общее количество всех 29000112 и 29000117 с пустыми ячейками

 

Ответить

Manyasha

Дата: Воскресенье, 17.01.2016, 19:59 |
Сообщение № 11

Группа: Модераторы

Ранг: Старожил

Сообщений: 2198


Репутация:

898

±

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


Excel 2010, 2016

drblasster88, нашла ошибку
[vba]

Код

If d3.Exists(dataBC(i, 2)) = False Then d3.Item(dataBC(i, 2)) = i

[/vba]
конечно же там не dataBC(i, 2), а dataBC(i, 1).

нужно что бы было общее количество

там только уникальные, Вы же в 1-м сообщении писали

в столбце B ищем уникальные значения по маске «29000112» и «29000117»

Поправила. Проверяйте новый код. Ненужное для «Не отправлено Справок» потом удалите, я прокомментила все
[vba]

Код

Sub report()
    Application.ScreenUpdating = False
    Dim f As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = «Please select a file»: .InitialFileName = ThisWorkbook.Path
        .Filters.Add «Excel», «*.xls;*.xlsx;*.xlsm;*.xlsb», 1: .AllowMultiSelect = False
        If .Show = False Then Exit Sub: If .SelectedItems.Count = 0 Then Exit Sub
        f = .SelectedItems(1)
    End With
    Set shRep = ThisWorkbook.Sheets(1)
    Set openWb = Workbooks.Open(f)
    Set shData = openWb.Sheets(1)
    shRep.Range(«c3») = WorksheetFunction.CountIf(shData.Columns(1), «Решение о приостановлении операций по счетам (НО)»)
    shRep.Range(«f3») = WorksheetFunction.CountIf(shData.Columns(1), «Решение об отмене приостановления операций по счетам (НО)»)
    Set d1 = CreateObject(«Scripting.Dictionary»)
    Set d3 = CreateObject(«Scripting.Dictionary»)
    Dim dataBC
    dataBC = shData.[b1].Resize(shData.UsedRange.Rows.Count, 2)
    For i = 1 To UBound(dataBC)
        If InStr(dataBC(i, 2), «BOS1_RPO») Or InStr(dataBC(i, 2), «BOS1_RBN») Then
            If d1.Exists(dataBC(i, 2)) = False Then d1.Item(dataBC(i, 2)) = i
        End If
        If (InStr(dataBC(i, 1), «29000112») Or InStr(dataBC(i, 1), «29000117»)) _
            And Trim(dataBC(i, 2)) = «» Then
            If Trim(dataBC(i — 1, 2)) = «» And Trim(dataBC(i + 1, 2)) = «» Then
                ‘Считаем уникальные
                If d3.Exists(dataBC(i, 1)) = False Then d3.Item(dataBC(i, 1)) = i
                ‘Считаем общее кол-во
                k = k + 1
                ‘Список значений в строчку
                listStr = listStr & dataBC(i, 1) & «, «
            End If
        End If
    Next i
    shRep.Range(«d3») = d1.Count
    shRep.Range(«e3») = shRep.Range(«c3») — shRep.Range(«d3»)
    ‘Выводим общее кол-во
    shRep.Range(«i3») = k
    ‘Выводим кол-во уникальных
    shRep.Range(«j3») = d3.Count
    ‘Выводим весь список значений
    shRep.Range(«k3») = Mid(listStr, 1, Len(listStr) — 2)
    openWb.Close
    Application.ScreenUpdating = True
End Sub

[/vba]

К сообщению приложен файл:

5297486.xlsm
(24.7 Kb)


ЯД: 410013299366744 WM: R193491431804

Сообщение отредактировал ManyashaВоскресенье, 17.01.2016, 20:02

 

Ответить

drblasster88

Дата: Воскресенье, 17.01.2016, 20:29 |
Сообщение № 12

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

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

Сообщений: 18


Репутация:

0

±

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


Excel 2007

Да, теперь все идеально! Спасибо Вам большое, вы меня очень выручили!!! Ваши реквизиты работоспособны ЯД: 410013299366744 WM: R193491431804?
И последний глупый вопрос: Как мне вывести из выгрузки значение ячейки А8 (там дата выгрузки зашита) в какую-нибудь ячейку отчета?

 

Ответить

Manyasha

Дата: Воскресенье, 17.01.2016, 20:42 |
Сообщение № 13

Группа: Модераторы

Ранг: Старожил

Сообщений: 2198


Репутация:

898

±

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


Excel 2010, 2016

а как же)
для даты добавьте 1 строчку в конец кода:
[vba]

Код

    ‘Дату выгрузки записываем в А1
    shRep.Range(«a1») = shData.Range(«a8»)
    openWb.Close
    Application.ScreenUpdating = True
End Sub

[/vba]


ЯД: 410013299366744 WM: R193491431804

 

Ответить

drblasster88

Дата: Воскресенье, 17.01.2016, 22:15 |
Сообщение № 14

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

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

Сообщений: 18


Репутация:

0

±

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


Excel 2007

Марин, сможете подсказать как запускать макрос без диалогового окна, что бы не выбирать нужный файлик?
Пытаюсь подставить в код команду…не получается
Workbooks.Open Filename:= _
«C:UsersАлександрDesktopДневной объем ЮЛ.24Выгрузки за Т-2ВВБ.xlsm»

 

Ответить

Manyasha

Дата: Воскресенье, 17.01.2016, 22:57 |
Сообщение № 15

Группа: Модераторы

Ранг: Старожил

Сообщений: 2198


Репутация:

898

±

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


Excel 2010, 2016

drblasster88, вот так попробуйте
[vba]

Код

Set openWb = Workbooks.Open(«C:UsersАлександрDesktopДневной объем ЮЛ.24Выгрузки за Т-2ВВБ.xlsm»)

[/vba]


ЯД: 410013299366744 WM: R193491431804

 

Ответить

drblasster88

Дата: Воскресенье, 17.01.2016, 23:02 |
Сообщение № 16

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

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

Сообщений: 18


Репутация:

0

±

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


Excel 2007

Я так пробовал, ругается на последнюю строку
[vba]

Код

Application.ScreenUpdating = False
Set openWb = Workbooks.Open(«C:UsersАлександрDesktopДневной объем ЮЛ.24Выгрузки за Т-2ВВБ.xlsm»)
Set shData = openWb.Sheets(1)
shRep.Range(«c3») = WorksheetFunction.CountIf(shData.Columns(1), «Решение о приостановлении операций по счетам (НО)»)

[/vba]
[moder]Для кода макроса используйте спецтеги. Кнопка #. Поправил Вам пост.

Сообщение отредактировал _Boroda_Понедельник, 18.01.2016, 07:42

 

Ответить

Manyasha

Дата: Понедельник, 18.01.2016, 10:12 |
Сообщение № 17

Группа: Модераторы

Ранг: Старожил

Сообщений: 2198


Репутация:

898

±

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


Excel 2010, 2016

Ну так на последнюю же, а не на метод open.
Показывайте в файле или код целиком.


ЯД: 410013299366744 WM: R193491431804

 

Ответить

drblasster88

Дата: Понедельник, 18.01.2016, 21:06 |
Сообщение № 18

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

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

Сообщений: 18


Репутация:

0

±

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


Excel 2007

Странно, а сегодня получилось….мистика
Но сегодня другая проблема, после того как вы добавили функцию
[vba]

Код

‘Выводим весь список значений
shRep.Range(«I3») = Mid(listStr, 1, Len(listStr) — 2)

[/vba]
В тех случаях, когда выводить нечего, т.е. поле «не отправлено ответов» остается пустым…макрос начинает ругаться на выше указанную строку…видимо как раз потому что нечего выводить. Можно ли сделать возможным оба варианта исхода событий?
[moder]Повторное нарушение п.3 Правил форума в части тегов. Игнорирование замечаний администрации. Первое замечание.

Сообщение отредактировал _Boroda_Понедельник, 18.01.2016, 21:30

 

Ответить

drblasster88

Дата: Воскресенье, 21.02.2016, 17:34 |
Сообщение № 19

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

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

Сообщений: 18


Репутация:

0

±

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


Excel 2007

Добрый вечер, прошу прощения у администраторов, так был увлечен, что ваше замечание не увидел. Исправлюсь.

Manyasha, Возвращаясь к коду работает отлично. Спасибо большое. Подскажите еще пожалуйста команду вывода значений не в строчку, а в столбец. Как показала практика со строчкой очень не удобно потом работать
[vba]

Код

‘Список значений в строчку
                 listStr = listStr & dataBC(i, 1) & «, «
             End If
         End If
     Next i
     shRep.Range(«d3») = d1.Count
     shRep.Range(«e3») = shRep.Range(«c3») — shRep.Range(«d3»)
     ‘Выводим общее кол-во
     shRep.Range(«i3») = k
     ‘Выводим кол-во уникальных
     shRep.Range(«j3») = d3.Count
     ‘Выводим весь список значений
     shRep.Range(«k3») = Mid(listStr, 1, Len(listStr) — 2)

[/vba]

 

Ответить

Manyasha

Дата: Вторник, 23.02.2016, 11:56 |
Сообщение № 20

Группа: Модераторы

Ранг: Старожил

Сообщений: 2198


Репутация:

898

±

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


Excel 2010, 2016

drblasster88, попробуйте так:
[vba]

Код

‘Список значений в столбик
                shRep.Range(«k» & 3+k) = dataBC(i, 1)
            End If
        End If
    Next i
    shRep.Range(«d3») = d1.Count
    shRep.Range(«e3») = shRep.Range(«c3») — shRep.Range(«d3»)
    ‘Выводим общее кол-во
    shRep.Range(«i3») = k
    ‘Выводим кол-во уникальных
    shRep.Range(«j3») = d3.Count
    ‘Выводим весь список значений
    ‘ shRep.Range(«k3») = Mid(listStr, 1, Len(listStr) — 2)

[/vba]


ЯД: 410013299366744 WM: R193491431804

 

Ответить

Хитрости »

1 Май 2011              532180 просмотров


Как получить список уникальных(не повторяющихся) значений?

Представим себе большой список различных наименований, ФИО, табельных номеров и т.п. А необходимо из этого списка оставить список все тех же наименований, но чтобы они не повторялись — т.е. удалить из этого списка все дублирующие записи. Как это иначе называют: создать список уникальных элементов, список неповторяющихся, без дубликатов. Для этого существует несколько способов: встроенными средствами Excel, встроенными формулами и, наконец, при помощи кода Visual Basic for Application(VBA) и сводных таблиц. В этой статье рассмотрим каждый из вариантов.

  • При помощи встроенных возможностей Excel 2007 и выше
  • При помощи Расширенного фильтра
  • При помощи формул
  • При помощи кодов Visual Basic for Application(VBA) — макросы, включая универсальный код выборки из произвольного диапазона
  • При помощи сводных таблиц

при помощи встроенных возможностей Excel 2007 и выше

В Excel 2007 и 2010 это сделать проще простого — есть специальная команда, которая так и называется — Удалить дубликаты (Remove Duplicates). Расположена она на вкладке Данные (Data) подраздел Работа с данными (Data tools)

Как использовать данную команду. Выделяете столбец(или несколько) с теми данными, в которых надо удалить дублирующие записи. Идете на вкладку Данные (Data)Удалить дубликаты (Remove Duplicates).

Если выделить один столбец, но рядом с ним будут еще столбцы с данными(или хотя бы один столбец), то Excel предложит выбрать: расширить диапазон выборки этим столбцом или оставить выделение как есть и удалить данные только в выделенном диапазоне. Важно помнить, что если не расширить диапазон, то данные будут изменены лишь в одном столбце, а данные в прилегающем столбце останутся без малейших изменений.

Появится окно с параметрами удаления дубликатов

Ставите галочки напротив тех столбцов, дубликаты в которых надо удалить и жмете Ок. Если в выделенном диапазоне так же расположены заголовки данных, то лучше поставить флаг Мои данные содержат заголовки, чтобы случайно не удалить данные в таблице(если они вдруг полностью совпадают со значением в заголовке).


Способ 1: Расширенный фильтр

В случае с Excel 2003 все посложнее. Там нет такого инструмента, как Удалить дубликаты. Но зато есть такой замечательный инструмент, как Расширенный фильтр. В 2003 этот инструмент можно найти в ДанныеФильтрРасширенный фильтр. Прелесть этого метода в том, с его помощью можно не портить исходные данные, а создать список в другом диапазоне.

В 2007-2010 Excel, он тоже есть, но немного запрятан. Расположен на вкладке Данные (Data), группа Сортировка и фильтр (Sort & Filter)Дополнительно (Advanced)

Как его использовать: запускаем указанный инструмент — появляется диалоговое окно:

  • Обработка: Выбираем Скопировать результат в другое место (Copy to another location).
  • Исходный диапазон (List range): Выбираем диапазон с данными(в нашем случае это А1:А51).
  • Диапазон критериев (Criteria range): в данном случае оставляем пустым.
  • Поместить результат в диапазон (Copy to): указываем первую ячейку для вывода данных — любую пустую(на картинке — E2).
  • Ставим галочку Только уникальные записи (Unique records only).
  • Жмем Ок.

Примечание: если вы хотите поместить результат на другой лист, то просто так указать другой лист не получится. Вы сможете указать ячейку на другом листе, но…Увы и ах…Excel выдаст сообщение, что не может скопировать данные на другие листы. Но и это можно обойти, причем довольно просто. Надо всего лишь запустить Расширенный фильтр с того листа, на который хотим поместить результат. А в качестве исходных данных выбираем данные с любого листа — это дозволено.

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

Для этого надо просто в пункте Обработка выбрать Фильтровать список на месте (Filter the list, in-place).


Способ 2: Формулы

Этот способ сложнее в понимании для неопытных пользователей, но зато он создает список уникальных значений, не изменяя при этом исходные данные. Ну и он более динамичен: если изменить данные в исходной таблице, то изменится и результат. Иногда это бывает полезно. Попытаюсь объяснить на пальцах что и к чему: допустим, список с данными у Вас расположен в столбце

А

(

А1:А51

, где

А1

— заголовок). Выводить список мы будем в столбец

С

, начиная с ячейки

С2

. Формула в

C2

будет следующая:

{=ИНДЕКС($A$2:$A$51;НАИМЕНЬШИЙ(ЕСЛИ(СЧЁТЕСЛИ($C$1:C1;$A$2:$A$51)=0;СТРОКА($A$1:$A$50));1))}
{=INDEX($A$2:$A$51;SMALL(IF(COUNTIF($C$1:C1;$A$2:$A$51)=0;ROW($A$1:$A$50));1))}
Детальный разбор работы данной формулы приведен в статье: Как просмотреть этапы вычисления формул

Надо отметить, что эта формула является формулой массива. Об этом могут сказать фигурные скобки, в которые заключена данная формула. А вводится такая формула в ячейку сочетанием клавиш —

Ctrl

+

Shift

+

Enter

(при этом сами скобки вводить не надо — они появятся сами после ввода формулы тремя клавишами

Ctrl

+

Shift

+

Enter

). После того, как мы ввели эту формулу в

C2

мы её должны скопировать и вставить в несколько строк так, чтобы точно отобразить все уникальные элементы. Как только формула в нижних ячейках вернет

#ЧИСЛО!(#NUM!)

— это значит все элементы отображены и ниже протягивать формулу нет смысла. Чтобы ошибку избежать и сделать формулу более универсальной(не протягивая каждый раз до появления ошибки) можно использовать нехитрую проверку:

для Excel 2007 и выше:
{=ЕСЛИОШИБКА(ИНДЕКС($A$2:$A$51;НАИМЕНЬШИЙ(ЕСЛИ(СЧЁТЕСЛИ($C$1:C1;$A$2:$A$51)=0;СТРОКА($A$1:$A$50));1));»»)}
{=IFERROR(INDEX($A$2:$A$51;SMALL(IF(COUNTIF($C$1:C1;$A$2:$A$51)=0;ROW($A$1:$A$50));1));»»)}
для Excel 2003:
{=ЕСЛИ(ЕОШ(НАИМЕНЬШИЙ(ЕСЛИ(СЧЁТЕСЛИ($C$1:C1;$A$2:$A$51)=0;СТРОКА($A$1:$A$50));1));»»;ИНДЕКС($A$2:$A$51;НАИМЕНЬШИЙ(ЕСЛИ(СЧЁТЕСЛИ($C$1:C1;$A$2:$A$51)=0;СТРОКА($A$1:$A$50));1)))}
{=IF(ISERR(SMALL(IF(COUNTIF($C$1:C1;$A$2:$A$51)=0;ROW($A$1:$A$50));1));»»;INDEX($A$2:$A$51;SMALL(IF(COUNTIF($C$1:C1;$A$2:$A$51)=0;ROW($A$1:$A$50));1)))}

Тогда вместо ошибки 

#ЧИСЛО!(#NUM!)

у вас будут пустые ячейки(не совсем пустые, конечно — с формулами :-)).
Чуть подробнее про отличия и нюансы формул ЕСЛИОШИБКА и ЕСЛИ(ЕОШ можно прочесть в этой статье: Как в ячейке с формулой вместо ошибки показать 0


Для пользователей Excel 2021 выше, а так же пользователей Excel 365(с активной подпиской) — использовать формулы для извлечения уникальных элементов проще простого. В этих версиях появилась функция

УНИК(UNIQUE)

, которая как раз получает список уникальных значений на основании переданного диапазона:

=УНИК($A$2:$A$51)
=UNIQUE($A$2:$A$51)

Что самое важное в данном случае — это функция динамического массива и вводить её надо только в одну ячейку C2, а результат она поместит сама в нужное количество ячеек.


Способ 3: код VBA

Данный подход потребует разрешения макросов и базовых знаний о работе с ними. Если не уверены в своих знаниях для начала рекомендую прочитать эти статьи:

  • Что такое макрос и где его искать? к статье приложен видеоурок
  • Что такое модуль? Какие бывают модули? потребуется, чтобы понять куда вставлять приведенные ниже коды

Оба приведенных ниже кода следует помещать в стандартный модуль. Макросы должны быть разрешены.

Исходные данные оставим в том же порядке — список с данными расположен в столбце «А«(А1:А51, где А1 — заголовок). Только выводить список мы будем не в столбец С, а в столбец Е, начиная с ячейки Е2:

Sub Extract_Unique()
    Dim vItem, avArr, li As Long
    ReDim avArr(1 To Rows.Count, 1 To 1)
    With New Collection
        On Error Resume Next
        For Each vItem In Range("A2", Cells(Rows.Count, 1).End(xlUp)).Value
            'Cells(Rows.Count, 1).End(xlUp) – определяет последнюю заполненную ячейку в столбце А
            .Add vItem, CStr(vItem)
            If Err = 0 Then
                li = li + 1: avArr(li, 1) = vItem
            Else: Err.Clear
            End If
        Next
    End With
    If li Then [E2].Resize(li).Value = avArr
End Sub

С помощью данного кода можно извлечь уникальные не только из одного столбца, но и из любого диапазона столбцов и строк. Если вместо строки
Range(«A2», Cells(Rows.Count, 1).End(xlUp)).Value
указать Selection.Value, то результатом работы кода будет список уникальных элементов из выделенного на активном листе диапазона. Только тогда неплохо бы и ячейку вывода значений изменить — вместо [E2] поставить ту, в которой данных нет.
Так же можно указать конкретный диапазон:

Или другой столбец:

Range("C2", Cells(Rows.Count, 3).End(xlUp)).Value

здесь отдельно стоит обратить внимание то, что в данном случае помимо изменения А2 на С2 изменилась и цифра 1 на 3. Это указание на номер столбца, в котором необходимо определить последнюю заполненную ячейку, чтобы код не просматривал лишние ячейки. Подробнее про это можно прочитать в статье: Как определить последнюю ячейку на листе через VBA?

Универсальный код выбора уникальных значений
Код ниже можно применять для любых диапазонов. Достаточно запустить его, указать диапазон со значениями для отбора только неповторяющихся(допускается выделение более одного столбца) и ячейку для вывода результата. Указанные ячейки будут просмотрены, из них будут отобраны только уникальные значения(пустые ячейки при этом пропускаются) и результирующий список будет записан, начиная с указанной ячейки.

Sub Extract_Unique()
    Dim x, avArr, li As Long
    Dim avVals
    Dim rVals As Range, rResultCell As Range
 
    On Error Resume Next
    'запрашиваем адрес ячеек для выбора уникальных значений
    Set rVals = Application.InputBox("Укажите диапазон ячеек для выборки уникальных значений", "Запрос данных", "A2:A51", Type:=8)
    If rVals Is Nothing Then 'если нажата кнопка Отмена
        Exit Sub
    End If
    'если указана только одна ячейка - нет смысла выбирать
    If rVals.Count = 1 Then
        MsgBox "Для отбора уникальных значений требуется указать более одной ячейки", vbInformation, "www.excel-vba.ru"
        Exit Sub
    End If
    'отсекаем пустые строки и столбцы вне рабочего диапазона
    Set rVals = Intersect(rVals, rVals.Parent.UsedRange)
    'если указаны только пустые ячейки вне рабочего диапазона
    If rVals Is Nothing Then
        MsgBox "Недостаточно данных для выбора значений", vbInformation, "www.excel-vba.ru"
        Exit Sub
    End If
    avVals = rVals.Value
    'запрашиваем ячейку для вывода результата
    Set rResultCell = Application.InputBox("Укажите ячейку для вставки отобранных уникальных значений", "Запрос данных", "E2", Type:=8)
    If rResultCell Is Nothing Then 'если нажата кнопка Отмена
        Exit Sub
    End If
    'определяем максимально возможную размерность массива для результата
    ReDim avArr(1 To Rows.Count, 1 To 1)
    'при помощи объекта Коллекции(Collection)
    'отбираем только уникальные записи,
    'т.к. Коллекции не могут содержать повторяющиеся значения
    With New Collection
        On Error Resume Next
        For Each x In avVals
            If Len(CStr(x)) Then 'пропускаем пустые ячейки
                .Add x, CStr(x) 'если добавляемый элемент уже есть в Коллекции - возникнет ошибка
                'если же ошибки нет - такое значение еще не внесено,
                'добавляем в результирующий массив
                If Err = 0 Then
                    li = li + 1
                    avArr(li, 1) = x
                Else
                    'обязательно очищаем объект Ошибки
                    Err.Clear
                End If
            End If
        Next
    End With
    'записываем результат на лист, начиная с указанной ячейки
    If li Then rResultCell.Cells(1, 1).Resize(li).Value = avArr
End Sub

Способ 4: Сводные таблицы

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

  • Выделяем один или несколько столбцов в таблице, переходим на вкладку Вставка(Insert) -группа Таблица(Table)Сводная таблица(PivotTable)
  • В диалоговом окне Создание сводной таблицы(Create PivotTable) проверяем правильность выделения диапазона данных (или установить новый источник данных)
  • указываем место размещения Сводной таблицы:
    • На новый лист (New Worksheet)
    • На существующий лист (Existing Worksheet)
  • подтверждаем создание нажатием кнопки OK

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

  • выделил диапазон A1:B51 на листе Извлечение по критерию
  • вызвал меню вставки сводной таблицы: вкладка Вставка(Insert) -группа Таблица(Table)Сводная таблица(PivotTable)
    выбрал вставить на новый лист(New Worksheet)
  • назвал этот лист Уникальные сводной таблицей
  • поле Данные поместил в область строк
  • поле ФИО в область фильтра. Почему? Чтобы удобно было выбирать одно или несколько ФИО и в сводной отображался бы список уникальных месяцев только для выбранных фамилий
    Отбор уникальных сводной таблицей

В чем неудобство работы со сводными в данном случае: при изменении в исходных данных сводную таблицу придется обновлять вручную: Выделить любую ячейку сводной таблицы -Правая кнопка мыши —Обновить(Refresh) или вкладка Данные(Data)Обновить все(Refresh all)Обновить(Refresh). А если исходные данные пополняются динамически и того хуже — надо будет заново указывать диапазон исходных данных. И еще один минус — данные внутри сводной таблицы нельзя менять. Поэтому если с полученным списком необходимо будет работать в дальнейшем, то после создания нужного списка при помощи сводной его надо скопировать и вставить на нужный лист.

Чтобы лучше понимать все действия и научиться обращаться со сводными таблицами настоятельно рекомендую ознакомиться со статьей Общие сведения о сводных таблицах — к ней приложен видеоурок, в котором я наглядно демонстрирую простоту и удобство работы с основными возможностями сводных таблиц.


В приложенном примере помимо описанных приемов, записана чуть более сложная вариация извлечения уникальных элементов формулой и кодом, а именно: извлечение уникальных элементов по критерию. О чем речь: если в одном столбце фамилии, а во втором(В) некие данные(в файле это месяцы) и требуется извлечь уникальные значения столбца В только для выбранной фамилии. Примеры подобных извлечений уникальных расположены на листе Извлечение по критерию.

Скачать пример:

  Tips_All_ExtractUnique.xls (108,0 KiB, 18 432 скачиваний)

Также см.:
Работа с дубликатами
Как подсчитать количество повторений
Общие сведения о сводных таблицах


Статья помогла? Поделись ссылкой с друзьями!

  Плейлист   Видеоуроки


Поиск по меткам



Access
apple watch
Multex
Power Query и Power BI
VBA управление кодами
Бесплатные надстройки
Дата и время
Записки
ИП
Надстройки
Печать
Политика Конфиденциальности
Почта
Программы
Работа с приложениями
Разработка приложений
Росстат
Тренинги и вебинары
Финансовые
Форматирование
Функции Excel
акции MulTEx
ссылки
статистика

Отбор уникальных значений из списка в VBA Excel с помощью объекта Collection. Выгрузка уникальных элементов в ListBox и ячейки рабочего листа. Скачать файл с примером кода.

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

При написании макросов для работы с данными в VBA Excel иногда возникает необходимость отбора уникальных значений из списка с повторяющимися элементами. Для этого можно воспользоваться следующим кодом:

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

Sub ОтборУникальных()

‘Объявляем переменные

‘myRange — диапазон ячеек, заполненный исходным списком элементов

‘myCell — отдельная ячейка диапазона

‘myCollection — коллекция

‘myElement — элемент коллекции (должен быть типа «Variant»)

Dim myRange As Range, myCell As Range, myCollection As New Collection, _

myElement As Variant, i As Long

‘присваиваем переменной myRange диапазон ячеек с исходным списком элементов

Set myRange = Range(«A1:A20»)

‘заполняем новую коллекцию уникальными элементами

On Error Resume Next

For Each myCell In myRange

myCollection.Add CStr(myCell.Value), CStr(myCell.Value)

Next myCell

On Error GoTo 0

На этом отбор уникальных значений завершен. Коллекция заполнена уникальными элементами.

Добавление уникальных элементов в ListBox

Теперь можно добавить уникальные значения в ListBox, если перед этим создать форму UserForm1 и на нее добавить элемент управления ListBox1:

For Each myElement In myCollection

UserForm1.ListBox1.AddItem myElement

Next myElement

ListBox заполнен уникальными значениями из коллекции. Другие способы заполнения ListBox и ComboBox смотрите здесь.

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

А так можно добавить уникальные элементы в ячейки столбца «В» активного рабочего листа:

For Each myElement In myCollection

i = i + 1

Cells(i, 2) = myElement

Next myElement

При необходимости сортируем полученный список в столбце «В»:

Range(Cells(1, 2), Cells(i, 2)).Sort Key1:=Range(«B1»), Order1:=xlAscending, _

Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

А также можно отобразить количество найденных уникальных элементов, если, конечно, на форму UserForm1 добавлен элемент управления Label1:

UserForm1.Label1.Caption = «Уникальных элементов: « & myCollection.Count

‘отображаем форму

UserForm1.Show

End Sub

Если вам необходимо в ListBox или ComboBox загрузить отсортированный список, его элементы можно добавить с листа Excel после сортировки, в данном примере из диапазона Range(Cells(1, 2), Cells(i, 2)).

Обратите внимание, что в представленном коде VBA Excel для отбора уникальных значений из списка, выгрузки их в ListBox и записи на рабочий лист идет сплошная нумерация от Sub ОтборУникальных() и до End Sub.

Для наглядного ознакомления с работой представленного кода вы можете скачать демонстрационный файл.


Смотрите, как удалить повторяющиеся значения из диапазона ячеек в VBA Excel с помощью метода Range.RemoveDuplicates и отобрать уникальные значения из списка с помощью объекта Dictionary.


Функция UniqueValues возвращает коллекцию, содержащую уникальные непустые значения из диапазона ячеек (или массива)

Function UniqueValues(ByVal arr) As Collection
    ' функция получает в качестве параметра массив любой размерности
    ' возвращает коллекцию уникальных НЕПУСТЫХ значений
    Set UniqueValues = New Collection: On Error Resume Next
    For Each v In arr
        v = Trim(v): If Len(v) Then UniqueValues.Add CStr(v), CStr(v)
    Next v
End Function
 
 
Sub ПримерИспользования_UniqueValues()
    For Each v In UniqueValues([a3:b6500].Value)
        Debug.Print v
    Next
End Sub

Если же требуется найти уникальные значения в массиве из нескольких столбцов, или получить результат (уникальные значения) в виде массива (для последующей записи на лист, или в элемент управления типа ComboBox или ListBox), то используйте функцию UniqueValuesFromArray:
http://excelvba.ru/code/UniqueValuesFromArray

(добавлено)
Если диапазон состоит из нескольких несмежных диапазонов — то используйте такую функцию:

Function UniqueValuesFormRange(ByVal ra As Range) As Collection
    ' функция получает в качестве параметра диапазон ячеек
    ' возвращает коллекцию уникальных НЕПУСТЫХ значений
    Set UniqueValuesFormRange = New Collection: On Error Resume Next
    Dim ar As Range
    For Each ar In ra.Areas
        For Each v In ar.Value
            v = Trim(v): If Len(v) Then UniqueValuesFormRange.Add CStr(v), CStr(v)
        Next v
    Next ar
End Function

Пример её использования:

Sub ПримерИспользования_UniqueValuesFormRange()
    For Each v In UniqueValuesFormRange(Selection)
        Debug.Print v
    Next
End Sub
  • 41361 просмотр

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.

Понравилась статья? Поделить с друзьями:
  • Количество точек в строке excel
  • Количество элементов в списке excel
  • Количество типов данных в ms excel
  • Количество числовых ячеек excel
  • Количество студентов имеющих рост 180 excel