Уникальные записи по части строки

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

Уникальные записи по части строки (Макросы/Sub)

barina

Дата: Пятница, 02.10.2015, 12:20 | Сообщение № 1

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

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

Сообщений: 27

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

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

Excel 2003

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

К сообщению приложен файл: 2713147.xlsx (9.4 Kb)

Ответить

Manyasha

Дата: Пятница, 02.10.2015, 12:47 | Сообщение № 2

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

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

Сообщений: 2198

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

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

Excel 2010, 2016

barina, так подойдет?
[vba]

Код

Sub ttt()
     Dim rng As Range, cell As Range
     Set rng = Range("b2:b" & Cells(Rows.Count, 2).End(xlUp).Row)
     With CreateObject("Scripting.Dictionary"): .CompareMode = vbTextCompare
         For Each cell In rng
             If Split(cell, "_")(0) <> "" Then .Item(Split(cell, "_")(0)) = .Item(Split(cell, "_")(0)) + 1
         Next
         Range("d2:d" & Cells(Rows.Count, 4).End(xlUp).Row).ClearContents
         Range("d2:d" & .Count + 1).Value = Application.WorksheetFunction.Transpose(.keys)
     End With
End Sub

[/vba]

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

ЯД: 410013299366744 WM: R193491431804

Ответить

RAN

Дата: Пятница, 02.10.2015, 12:52 | Сообщение № 3

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

Ранг: Экселист

Сообщений: 5660

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

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

2010

[vba]

Код

Sub мяу()
     Dim arr, i&
     arr = Range(Cells(2, 2), Cells(Rows.Count, 2).End(xlUp)).Value
     With CreateObject("Scripting.Dictionary")
         For i = 1 To UBound(arr)
             .Item(Split(arr(i, 1), "_")(0)) = 1
         Next
         Cells(2, "F").Resize(.Count) = Application.Transpose(.keys)
     End With
End Sub

[/vba]