Здравствуйте! Помогите пожалуйста разобраться.. Какая формула бы решила задачу с условиями: - Есть 2000 уникальных ячеек в столбце А, в виде текста + цифр + символов по типу "амперсанд" И надо найти уникальные слова и записать их в столбец С. Файл пример приложил. Огромная благодарность форуму!
Здравствуйте! Помогите пожалуйста разобраться.. Какая формула бы решила задачу с условиями: - Есть 2000 уникальных ячеек в столбце А, в виде текста + цифр + символов по типу "амперсанд" И надо найти уникальные слова и записать их в столбец С. Файл пример приложил. Огромная благодарность форуму!mishura08
В новых версиях есть всякие текстсплит() и фильтр(), у меня нет. Я бы делал несложным макросом на словаре, если уж так принципиально формулой - тогда массивной UDF, но это больше писать. У Вас какая версия Экселя?
В новых версиях есть всякие текстсплит() и фильтр(), у меня нет. Я бы делал несложным макросом на словаре, если уж так принципиально формулой - тогда массивной UDF, но это больше писать. У Вас какая версия Экселя?Hugo
mishura08, Скопировать столбец А, вставить в столбец С. Далее выделяете столбец С, переходите в меню в раздел "Данные" - "Удалить дубликаты" (сортировать в пределах указанного выделения) То? Или вам другое что-то надо?
mishura08, Скопировать столбец А, вставить в столбец С. Далее выделяете столбец С, переходите в меню в раздел "Данные" - "Удалить дубликаты" (сортировать в пределах указанного выделения) То? Или вам другое что-то надо?dmitriyaleksandrovichni
Тогда уж текст по столбцам чтоб выделить отдельно все слова, затем их скопировать все в один столбец, и затем удалить дубликаты. Вполне рабочий вариант для разовой задачи.
Тогда уж текст по столбцам чтоб выделить отдельно все слова, затем их скопировать все в один столбец, и затем удалить дубликаты. Вполне рабочий вариант для разовой задачи.Hugo
mishura08, Вот сейчас понял, что вам нужны слова, а не уникальные ячейки. Ок, чуть посложнее и подольше Вставляете значения из столбца А в столбец на другой вкладке (чтобы не запутаться) Далее в том же разделе "Данные" находите инструмент "Текст по столбцам" - с разделителями - символом разделителем является - пробел - далее и готово Далее надо всю эту красоту собрать в один столбец методом "копировать-вставить" и уже применить к этому столбцу "удалить дубликаты"
mishura08, Вот сейчас понял, что вам нужны слова, а не уникальные ячейки. Ок, чуть посложнее и подольше Вставляете значения из столбца А в столбец на другой вкладке (чтобы не запутаться) Далее в том же разделе "Данные" находите инструмент "Текст по столбцам" - с разделителями - символом разделителем является - пробел - далее и готово Далее надо всю эту красоту собрать в один столбец методом "копировать-вставить" и уже применить к этому столбцу "удалить дубликаты"dmitriyaleksandrovichni
Привет, Сергей. Можно и в коллекцию собирать, но там чуть больше кода. [vba]
Код
Sub tt() Dim a, i&, el a = [a1].CurrentRegion.Columns(1).Value
With CreateObject("Scripting.Dictionary") For i = 2 To UBound(a) For Each el In Split(a(i, 1), " ") .Item(el) = 0& Next Next [b2].Resize(.Count) = Application.Transpose(.keys) End With
Привет, Сергей. Можно и в коллекцию собирать, но там чуть больше кода. [vba]
Код
Sub tt() Dim a, i&, el a = [a1].CurrentRegion.Columns(1).Value
With CreateObject("Scripting.Dictionary") For i = 2 To UBound(a) For Each el In Split(a(i, 1), " ") .Item(el) = 0& Next Next [b2].Resize(.Count) = Application.Transpose(.keys) End With
Sub Макрос2() Dim arr1, arr2, m, n As Long, y As String arr1 = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row) Set dic1 = CreateObject("Scripting.Dictionary") Set dic2 = CreateObject("Scripting.Dictionary") ReDim arr2(LBound(arr1) To UBound(arr1), 1 To 1) For n = LBound(arr1) To UBound(arr1) arr2(n, 1) = Split(Trim(arr1(n, 1)), " ") For Each m In arr2(n, 1) If Not dic1.exists(m) Then dic1.Add m, m Else If Not dic2.exists(m) Then dic2.Add m, m End If Next Next For n = LBound(arr2) To UBound(arr2) For Each m In arr2(n, 1) If dic2.exists(m) Then y = y & "; " & m Next arr2(n, 1) = Mid(y, 3): y = "" Next [b2].Resize(UBound(arr2), 1) = arr2 End Sub
[/vba] PS наверное неправильно понял задание, вывел напротив каждой ячейки слова которые имеют повторение в остальном массиве
можно макросом [vba]
Код
Sub Макрос2() Dim arr1, arr2, m, n As Long, y As String arr1 = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row) Set dic1 = CreateObject("Scripting.Dictionary") Set dic2 = CreateObject("Scripting.Dictionary") ReDim arr2(LBound(arr1) To UBound(arr1), 1 To 1) For n = LBound(arr1) To UBound(arr1) arr2(n, 1) = Split(Trim(arr1(n, 1)), " ") For Each m In arr2(n, 1) If Not dic1.exists(m) Then dic1.Add m, m Else If Not dic2.exists(m) Then dic2.Add m, m End If Next Next For n = LBound(arr2) To UBound(arr2) For Each m In arr2(n, 1) If dic2.exists(m) Then y = y & "; " & m Next arr2(n, 1) = Mid(y, 3): y = "" Next [b2].Resize(UBound(arr2), 1) = arr2 End Sub
[/vba] PS наверное неправильно понял задание, вывел напротив каждой ячейки слова которые имеют повторение в остальном массивеmsi2102
Наверное опять не так понял, но решил сразу все сделать и повторяющиеся, и неповторяющиеся, и повторяющиеся в ячейке, и неповторяющиеся в ячейке [vba]
Код
Sub Макрос2() Dim arr1, arr2, m, n As Long, y As String arr1 = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row) Set dic1 = CreateObject("Scripting.Dictionary") Set dic2 = CreateObject("Scripting.Dictionary") ReDim arr2(LBound(arr1) To UBound(arr1), 1 To 1) For n = LBound(arr1) To UBound(arr1) arr2(n, 1) = Split(Trim(arr1(n, 1)), " ") For Each m In arr2(n, 1) If Not dic1.exists(m) Then dic1.Add m, m Else If Not dic2.exists(m) Then dic2.Add m, m End If Next Next For n = LBound(arr2) To UBound(arr2) For Each m In arr2(n, 1) If dic2.exists(m) Then y = y & "; " & m Next arr2(n, 1) = Mid(y, 3): y = "" Next [b2].Resize(UBound(arr2), 1) = arr2 End Sub
Sub Макрос3() Dim arr1, m, n As Long, y As String arr1 = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row) Set dic1 = CreateObject("Scripting.Dictionary") Set dic2 = CreateObject("Scripting.Dictionary") For n = LBound(arr1) To UBound(arr1) For Each m In Split(Trim(arr1(n, 1)), " ") If Not dic1.exists(m) Then dic1.Add m, m Else If Not dic2.exists(m) Then dic2.Add m, m End If Next Next ReDim arr1(1 To dic2.Count, 1 To 1) n = 1 For Each m In dic2 arr1(n, 1) = m: n = n + 1 Next [d2].Resize(UBound(arr1), 1) = arr1 End Sub
Sub Макрос4() Dim arr1, m, n As Long, y As String arr1 = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row) Set dic1 = CreateObject("Scripting.Dictionary") Set dic2 = CreateObject("Scripting.Dictionary") For n = LBound(arr1) To UBound(arr1) For Each m In Split(Trim(arr1(n, 1)), " ") If Not dic1.exists(m) Then dic1.Add m, m Else If Not dic2.exists(m) Then dic2.Add m, m End If Next Next For Each m In dic2 If dic1.exists(m) Then dic1.Remove (m) Next ReDim arr1(1 To dic1.Count, 1 To 1) n = 1 For Each m In dic1 arr1(n, 1) = m: n = n + 1 Next [e2].Resize(UBound(arr1), 1) = arr1 End Sub
Sub Макрос5() Dim arr1, arr2, m, n As Long, y As String arr1 = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row) Set dic1 = CreateObject("Scripting.Dictionary") Set dic2 = CreateObject("Scripting.Dictionary") ReDim arr2(LBound(arr1) To UBound(arr1), 1 To 1) For n = LBound(arr1) To UBound(arr1) arr2(n, 1) = Split(Trim(arr1(n, 1)), " ") For Each m In arr2(n, 1) If Not dic1.exists(m) Then dic1.Add m, m Else If Not dic2.exists(m) Then dic2.Add m, m End If Next Next For Each m In dic2 If dic1.exists(m) Then dic1.Remove (m) Next For n = LBound(arr2) To UBound(arr2) For Each m In arr2(n, 1) If dic1.exists(m) Then y = y & "; " & m Next arr2(n, 1) = Mid(y, 3): y = "" Next [c2].Resize(UBound(arr2), 1) = arr2 End Sub
[/vba]
Наверное опять не так понял, но решил сразу все сделать и повторяющиеся, и неповторяющиеся, и повторяющиеся в ячейке, и неповторяющиеся в ячейке [vba]
Код
Sub Макрос2() Dim arr1, arr2, m, n As Long, y As String arr1 = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row) Set dic1 = CreateObject("Scripting.Dictionary") Set dic2 = CreateObject("Scripting.Dictionary") ReDim arr2(LBound(arr1) To UBound(arr1), 1 To 1) For n = LBound(arr1) To UBound(arr1) arr2(n, 1) = Split(Trim(arr1(n, 1)), " ") For Each m In arr2(n, 1) If Not dic1.exists(m) Then dic1.Add m, m Else If Not dic2.exists(m) Then dic2.Add m, m End If Next Next For n = LBound(arr2) To UBound(arr2) For Each m In arr2(n, 1) If dic2.exists(m) Then y = y & "; " & m Next arr2(n, 1) = Mid(y, 3): y = "" Next [b2].Resize(UBound(arr2), 1) = arr2 End Sub
Sub Макрос3() Dim arr1, m, n As Long, y As String arr1 = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row) Set dic1 = CreateObject("Scripting.Dictionary") Set dic2 = CreateObject("Scripting.Dictionary") For n = LBound(arr1) To UBound(arr1) For Each m In Split(Trim(arr1(n, 1)), " ") If Not dic1.exists(m) Then dic1.Add m, m Else If Not dic2.exists(m) Then dic2.Add m, m End If Next Next ReDim arr1(1 To dic2.Count, 1 To 1) n = 1 For Each m In dic2 arr1(n, 1) = m: n = n + 1 Next [d2].Resize(UBound(arr1), 1) = arr1 End Sub
Sub Макрос4() Dim arr1, m, n As Long, y As String arr1 = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row) Set dic1 = CreateObject("Scripting.Dictionary") Set dic2 = CreateObject("Scripting.Dictionary") For n = LBound(arr1) To UBound(arr1) For Each m In Split(Trim(arr1(n, 1)), " ") If Not dic1.exists(m) Then dic1.Add m, m Else If Not dic2.exists(m) Then dic2.Add m, m End If Next Next For Each m In dic2 If dic1.exists(m) Then dic1.Remove (m) Next ReDim arr1(1 To dic1.Count, 1 To 1) n = 1 For Each m In dic1 arr1(n, 1) = m: n = n + 1 Next [e2].Resize(UBound(arr1), 1) = arr1 End Sub
Sub Макрос5() Dim arr1, arr2, m, n As Long, y As String arr1 = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row) Set dic1 = CreateObject("Scripting.Dictionary") Set dic2 = CreateObject("Scripting.Dictionary") ReDim arr2(LBound(arr1) To UBound(arr1), 1 To 1) For n = LBound(arr1) To UBound(arr1) arr2(n, 1) = Split(Trim(arr1(n, 1)), " ") For Each m In arr2(n, 1) If Not dic1.exists(m) Then dic1.Add m, m Else If Not dic2.exists(m) Then dic2.Add m, m End If Next Next For Each m In dic2 If dic1.exists(m) Then dic1.Remove (m) Next For n = LBound(arr2) To UBound(arr2) For Each m In arr2(n, 1) If dic1.exists(m) Then y = y & "; " & m Next arr2(n, 1) = Mid(y, 3): y = "" Next [c2].Resize(UBound(arr2), 1) = arr2 End Sub
Если задача "совсем разовая" и нужен конкретный разовый результат, который можно куда-то скопировать и работать дальше, то рекомендую воспользоваться услугами свободных (от лицензионных комплексов) Таблиц Google. Для этого скопировать колонку A из Excel в Гугл Таблицу, а потом в ячейку B1 ввести такую формулу: [vba]
Если задача "совсем разовая" и нужен конкретный разовый результат, который можно куда-то скопировать и работать дальше, то рекомендую воспользоваться услугами свободных (от лицензионных комплексов) Таблиц Google. Для этого скопировать колонку A из Excel в Гугл Таблицу, а потом в ячейку B1 ввести такую формулу: [vba]
jakim, а где hombres? Последний шаг наверное лишний, но я не берусь учить... P.S. вообще тогда уж нужно было бы оставить только те у кого 1. Т.е. согласно запросу - найти уникальные! Все остальные не уникальны... ))
jakim, а где hombres? Последний шаг наверное лишний, но я не берусь учить... P.S. вообще тогда уж нужно было бы оставить только те у кого 1. Т.е. согласно запросу - найти уникальные! Все остальные не уникальны... ))Hugo
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
