Sub WordsRating() Dim data As Range, i&, temp, cell, dic As Object, res As Worksheet Dim dKeys, dItems If Not Intersect(ActiveSheet.UsedRange, Selection) Is Nothing Then If Selection.Count > 1 Then Set data = Intersect(ActiveSheet.UsedRange, Selection) Else Set data = Selection End If Set dic = CreateObject("scripting.dictionary") For Each cell In data temp = Split(cell, " ") If UBound(temp) > 0 Then For i = 0 To UBound(temp) If Trim(temp(i)) <> "" Then dic(Trim(temp(i))) = dic(Trim(temp(i))) + 1 Next i End If Next cell Set res = ActiveWorkbook.Sheets.Add With res dKeys = dic.keys dItems = dic.items For i = 0 To UBound(dKeys) .Cells(i + 1, 1).Value = dKeys(i) .Cells(i + 1, 2) = dItems(i) Next i .Sort.SortFields.Clear .Sort.SortFields.Add Key:=Range("b1:b" & i) _ , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal With .Sort .SetRange Range("A1:B" & i) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With If UBound(dKeys) >= 300 Then .Range("a301:b" & i).ClearContents End With End If End Sub
[/vba]
Есть куча ячеек в столбце. 1. Макрос находит часто повторяющиеся слова (ТОП300) 2. Формула массива вытягивает все ячейки в которых встречается какое-то слово.
Внимание вопрос, как их объединить? Чтобы автоматически слова из само-провозглашенного списка ТОП300, поочередно в разных столбцах проставлялись в формулу массива.
Sub WordsRating() Dim data As Range, i&, temp, cell, dic As Object, res As Worksheet Dim dKeys, dItems If Not Intersect(ActiveSheet.UsedRange, Selection) Is Nothing Then If Selection.Count > 1 Then Set data = Intersect(ActiveSheet.UsedRange, Selection) Else Set data = Selection End If Set dic = CreateObject("scripting.dictionary") For Each cell In data temp = Split(cell, " ") If UBound(temp) > 0 Then For i = 0 To UBound(temp) If Trim(temp(i)) <> "" Then dic(Trim(temp(i))) = dic(Trim(temp(i))) + 1 Next i End If Next cell Set res = ActiveWorkbook.Sheets.Add With res dKeys = dic.keys dItems = dic.items For i = 0 To UBound(dKeys) .Cells(i + 1, 1).Value = dKeys(i) .Cells(i + 1, 2) = dItems(i) Next i .Sort.SortFields.Clear .Sort.SortFields.Add Key:=Range("b1:b" & i) _ , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal With .Sort .SetRange Range("A1:B" & i) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With If UBound(dKeys) >= 300 Then .Range("a301:b" & i).ClearContents End With End If End Sub
[/vba]
Есть куча ячеек в столбце. 1. Макрос находит часто повторяющиеся слова (ТОП300) 2. Формула массива вытягивает все ячейки в которых встречается какое-то слово.
Внимание вопрос, как их объединить? Чтобы автоматически слова из само-провозглашенного списка ТОП300, поочередно в разных столбцах проставлялись в формулу массива.AdwordsDirect
Сообщение отредактировал AdwordsDirect - Среда, 08.03.2017, 10:49
AdwordsDirect, почему тема не в разделе по VBA? Перенесла. Поправьте теги в посте, для кода нужно использовать кнопку #. Покажите файл-пример, что есть, что хотите.
AdwordsDirect, почему тема не в разделе по VBA? Перенесла. Поправьте теги в посте, для кода нужно использовать кнопку #. Покажите файл-пример, что есть, что хотите.Manyasha
Оригинальный файл не могу прикрепить т.к. он весит более 1МБ. Покажите пожалуйста принцип, как находить самые повторяющиеся слова из текста. И вытаскивать все ячейки с этими словами автоматически каждое слово в новый столбец.
Оригинальный файл не могу прикрепить т.к. он весит более 1МБ. Покажите пожалуйста принцип, как находить самые повторяющиеся слова из текста. И вытаскивать все ячейки с этими словами автоматически каждое слово в новый столбец.AdwordsDirect
Это конечно всё хорошо, но нужно это как-то в одно действие формулу связать.. То есть, чтобы на выходе получилось например 300 столбцов (как и самых встречаемых слов).
Это я мог делать и с помощью других формул. Все формулы у меня есть и макросы. Задача связать это в одно действие.
Это конечно всё хорошо, но нужно это как-то в одно действие формулу связать.. То есть, чтобы на выходе получилось например 300 столбцов (как и самых встречаемых слов).
Это я мог делать и с помощью других формул. Все формулы у меня есть и макросы. Задача связать это в одно действие.AdwordsDirect
Сообщение отредактировал AdwordsDirect - Четверг, 09.03.2017, 17:27
AdwordsDirect, весь файл не нужен, главное структура. Надеюсь, что она такая, как в файле в 3-м посте. Посмотрите такой вариант: [vba]
Код
Option Explicit Sub WordsRating() With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual: End With Dim t: t = Timer Dim data, lr&, i&, j&, r&, temp, cell, dic As Object lr = Cells(Rows.Count, 1).End(xlUp).Row data = Cells(3, 1).Resize(lr - 2).Value Set dic = CreateObject("scripting.dictionary") For Each cell In data temp = Split(LCase(cell), " ") If UBound(temp) >= 0 Then For i = 0 To UBound(temp) If Trim(temp(i)) <> "" And Len(Trim(temp(i))) > 2 Then dic(Trim(temp(i))) = dic(Trim(temp(i))) + 1 Next i End If Next cell [b1].CurrentRegion.Offset(, 1).ClearContents [b1].Resize(, dic.Count) = dic.keys [b2].Resize(, dic.Count) = dic.items ActiveSheet.Sort.SortFields.Clear ActiveSheet.Sort.SortFields.Add Key:=Cells(2, 2).Resize(, dic.Count), _ SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal With ActiveSheet.Sort .SetRange Cells(1, 2).Resize(2, dic.Count) .Header = xlGuess .MatchCase = False .Orientation = xlLeftToRight .SortMethod = xlPinYin .Apply End With
If dic.Count > 300 Then Cells(1, 2).Offset(, 300).Resize(, dic.Count - 300).ClearContents For j = 2 To Application.Min(300, dic.Count) + 1 dic.RemoveAll For i = 1 To UBound(data) If LCase(data(i, 1)) Like "*" & LCase(Cells(1, j)) & "*" Then dic(LCase(Trim(data(i, 1)))) = i End If Next i Cells(3, j).Resize(dic.Count) = Application.Transpose(dic.keys) Next j Debug.Print Timer - t With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic: End With MsgBox "Done!" End Sub
[/vba] Макрос обрабатывает строки 1-го столбца, начиная с 3-й.
AdwordsDirect, весь файл не нужен, главное структура. Надеюсь, что она такая, как в файле в 3-м посте. Посмотрите такой вариант: [vba]
Код
Option Explicit Sub WordsRating() With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual: End With Dim t: t = Timer Dim data, lr&, i&, j&, r&, temp, cell, dic As Object lr = Cells(Rows.Count, 1).End(xlUp).Row data = Cells(3, 1).Resize(lr - 2).Value Set dic = CreateObject("scripting.dictionary") For Each cell In data temp = Split(LCase(cell), " ") If UBound(temp) >= 0 Then For i = 0 To UBound(temp) If Trim(temp(i)) <> "" And Len(Trim(temp(i))) > 2 Then dic(Trim(temp(i))) = dic(Trim(temp(i))) + 1 Next i End If Next cell [b1].CurrentRegion.Offset(, 1).ClearContents [b1].Resize(, dic.Count) = dic.keys [b2].Resize(, dic.Count) = dic.items ActiveSheet.Sort.SortFields.Clear ActiveSheet.Sort.SortFields.Add Key:=Cells(2, 2).Resize(, dic.Count), _ SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal With ActiveSheet.Sort .SetRange Cells(1, 2).Resize(2, dic.Count) .Header = xlGuess .MatchCase = False .Orientation = xlLeftToRight .SortMethod = xlPinYin .Apply End With
If dic.Count > 300 Then Cells(1, 2).Offset(, 300).Resize(, dic.Count - 300).ClearContents For j = 2 To Application.Min(300, dic.Count) + 1 dic.RemoveAll For i = 1 To UBound(data) If LCase(data(i, 1)) Like "*" & LCase(Cells(1, j)) & "*" Then dic(LCase(Trim(data(i, 1)))) = i End If Next i Cells(3, j).Resize(dic.Count) = Application.Transpose(dic.keys) Next j Debug.Print Timer - t With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic: End With MsgBox "Done!" End Sub
[/vba] Макрос обрабатывает строки 1-го столбца, начиная с 3-й.Manyasha
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
