Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Подсчет ключевых слов в диапазоне ячеек
 
#1
03.05.2018 17:56:40
В строке указан номер, в () страна, после страны идет буквенное значение.
Необходимо сделать подсчет ключевых слов и что бы эти ключевые слова были отображены отдельно и напротив них к-во повторений.
Все ключевые слова в () , заранее нету понимания какие это будут ключевые слова

пример файла во вложении

видел вот эту статью , но там условие что все значения уже уже идут как одно слово на строку, также нужно заранее вписать какие именно должны быть ключевые слова, поэтому не подошел такой вариант
Изменено: Michael_777 - 03.05.2018 18:56:36
 
 
 
#2
03.05.2018 18:02:30
=СУММПРОИЗВ(ДЛСТР(A1:A3)-ДЛСТР(ПОДСТАВИТЬ(A1:A3;"(";)))
Формула посчитает общее количество ключей. Для вывода списка уникальных и их количества - только макрос. Или доп. формулы в двух столбцах (если ключей не более двух)
 
 
 
#3
03.05.2018 18:04:23
vikttur, ключей больше двух, гораздо больше

Спасибо!
 
 
 
#4
03.05.2018 18:06:37
vikttur, формула считает общее к-во слов в строке, а нужно что бы именно к-во слов в () и выноска по их частоте
 
 
 
#5
03.05.2018 18:10:46
А я Вам о чем написал?
Будете использовать для проверки, как считает макрос, который Вам, возможно, напишут.
 
 
 
#6
03.05.2018 18:20:41
Michael_777,
А страна Голландия во всех строках коряво написана, как Голлаедмя?
 
 
 
#7
03.05.2018 18:48:57
Если нет отторжения  доп столбцов и сводной, то см. пример.

Можно конечно формулами и список сделать и количества посчитать, но .....
Изменено: БМВ - 03.05.2018 18:59:51
По вопросам из тем форума, личку не читаю.
 
 
 
#8
03.05.2018 18:50:38
Цитата
Kuzmich написал:
А страна Голландия во всех строках коряво написана, как Голлаедмя?
А Ховатия не заинтриговала? :-)
Изменено: БМВ - 03.05.2018 18:51:08
По вопросам из тем форума, личку не читаю.
 
 
 
#9
03.05.2018 18:55:33
БМВ, Названия стран вписывали под диктовку человека с нарушениями дикции:)
Нужно бежать со всех ног, чтобы только оставаться на месте, а чтобы куда-то попасть, надо бежать как минимум вдвое быстрее!
 
 
 
#10
03.05.2018 19:06:56
Michael_777, пользовательская функция:
Код
Function fFind$(txt$)
Dim a%, b%, c%, aa1%(), aa2%(), ff$, DC As Object, arr()
a = 1: ReDim aa1(0): ReDim aa2(0)
Set DC = CreateObject("Scripting.Dictionary")
Do While InStr(a, txt, "(") 'считаем открывающие скобки
  ReDim Preserve aa1(b): a = InStr(a, txt, "(") + 1: aa1(b) = a - 1: b = b + 1
Loop
If b < 1 Then Exit Function
a = 1
Do While InStr(a, txt, ")") 'теперь закрывающие
  ReDim Preserve aa2(c): a = InStr(a, txt, ")") + 1: aa2(c) = a - 1: c = c + 1
Loop
If c < 1 Then Exit Function
a = 0
For b = 0 To UBound(aa1)
  For c = 0 To UBound(aa2)
    If aa1(b) < aa2(c) Then 'если позиция открывающей скобки раньше закрывающей
      ff = Mid$(txt, aa1(b) + 1, aa2(c) - aa1(b) - 1) 'извлекаем подстроку
      If Not DC.exists(ff) Then DC.Add ff, 1 Else DC.Item(ff) = DC.Item(ff) + 1 'наполняем словарь
      a = a + 1: Exit For
    End If
  Next
Next
If DC.Count < 1 Then Exit Function
arr = DC.keys(): ff = ""
'формируем итоговую строку, где через спец.символы возврата каретки расположены:
'- общее кол-во межскобочных подстрок
'- элемент 1
'- счетчик по элементу 1
'- и так далее
For b = 0 To UBound(arr)
  ff = ff & vbCrLf & arr(b) & vbCrLf & DC.Item(arr(b))
Next
fFind = a & ff
End Function
Изменено: Anchoret - 03.05.2018 19:07:22
 
 
 
#11
04.05.2018 10:00:01
Цитата
БМВ написал:
Цитата Kuzmich  написал:А страна Голландия во всех строках коряво написана, как Голлаедмя?А Ховатия не заинтриговала? :-)
Цитата
БМВ написал:
А Ховатия не заинтриговала? :-)
это писал доктор географических наук, понимаете, доктор)))
 
 
 
#12
04.05.2018 10:02:30
Off
Цитата
Michael_777 написал:
это писал доктор географических наук, понимаете, доктор)))
Я сразу почувствовал что нас лечат, но не от того :-)

NotOff
Michael_777, а по существу вопроса есть комменты?
По вопросам из тем форума, личку не читаю.
 
 
 
#13
04.05.2018 10:14:16
БМВ,пока что использую ваш вариант но в другой интерпретации. Ваша формула помогла определить какие же были ключевые слова в (), дальше нажимаю поиск и вручную закидываю каждое значение и вписываю цифру напротив ключевого слова, пока что так, но и это очень сильно помогло

Anchoret, изучаю как использовать этот путь
 
 
 
#14
04.05.2018 10:28:09
Michael_777, на всякий случай, правее оставил формулы, которые обрабатывают отдельную строку, если тянуть вправо, то последовательно будут ключевые слова из скобок.
По вопросам из тем форума, личку не читаю.
 
 
 
#15
04.05.2018 11:26:34
Цитата
что бы эти ключевые слова были отображены отдельно и напротив них к-во повторений.
Ключевые слова в столбце В, количество повторений в столбце С
Код
Sub iKeyWords()
Dim mo As Object
Dim Dict As Object
Dim n As Integer
Dim i As Long
Dim iLastRow As Long
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set Dict = CreateObject("scripting.dictionary"): Dict.comparemode = 1
 With CreateObject("VBScript.RegExp")
   .Global = True
   .IgnoreCase = True
   .MultiLine = True
   .Pattern = "\(.+?(?=\))"
  For i = 1 To iLastRow
     If .test(Cells(i, 1)) Then
       Set mo = .Execute(Cells(i, 1))
         For n = 0 To mo.Count - 1
             Dict.Item(Mid(mo(n), 2)) = Dict.Item(Mid(mo(n), 2)) + 1
         Next
    End If
   Next
 End With
 Range("B1").Resize(Dict.Count, 2) = Application.Transpose(Array(Dict.Keys, Dict.Items))
End Sub
 
 
 
#16
04.05.2018 13:22:38
Kuzmich,Работает! все супер! Спасибо!
 
 
 
#17
04.05.2018 13:50:07
Ну и альтернатива:
Код
Sub UniSeparate()
Dim arr(), a&, b%, c%, txt$, ff$, DC As Object, x&
arr = Intersect(ActiveCell.EntireColumn, ActiveCell.CurrentRegion).Value
Set DC = CreateObject("Scripting.Dictionary")
For x = 1 To UBound(arr)
  txt = arr(x, 1): b = InStr(txt, "("): c = InStr(txt, ")")
  Do While b * c > 0
    Select Case b
    Case Is < c And b > 0
      ff = Mid$(txt, b + 1, c - b - 1): a = a + 1
      b = InStr(b + 1, txt, "("): c = InStr(c + 1, txt, ")")
      If Not DC.exists(ff) Then DC.Add ff, 1 Else DC.Item(ff) = DC.Item(ff) + 1
    Case Is > c And c > 0: c = InStr(c + 1, txt, ")")
    Case Else: Exit Do
    End Select
  Loop
Next
If a < 1 Then Exit Sub
ActiveCell.Offset(, 3).Resize(DC.Count, 2) = Application.Transpose(Array(DC.keys(), DC.items()))
End Sub
Работает по столбцу, в котором активная ячейка. Выгрузка на пару столбцов правее исходного.

П.С.: Хитрый вариант транспонирования взял из кода выше.
Изменено: Anchoret - 04.05.2018 13:53:04
 
 
 
Страницы: 1
Наверх