Нужна такая вот программа: ЧАСТОТНЫЙ СЛОВАРЬ

[Daniil]

Нужна такая вот программа: ЧАСТОТНЫЙ СЛОВАРЬ

На форме 3 текстовых поля

В первое поле помещаем слова (одно слово в строчку)

Во второе поле помещаем текст

При нажатии на кнопку "Готово" программа должны найти сколько раз слова из поля 1 употребляются (встречаются) в поле 2 и поместить этот отчет в поле 3. Подскажите, как это реализовать? Чувствую, что эту программу не долго делать, но что-то не получается.....

Пример "Поле 1: "

Я
Ты
Он
Она
Мальчик

После 2

Я и еще один мальчик пошли гулять. Ты пойдешь с нами? Мальчик ответил: НЕТ! Я сказал: как хочешь. Мальчик согласился

После нажатия на кнопку "готово"

В поле 3 должно появиться:

Я - 2
Мальчик - 3
Ты - 1


По возможности слова в поле 3 должны быть отсортированы по количеству употреблению

Например:

Мальчик - 3
Я - 2
Ты - 1



Программу частнтного словаря можно везде скачать, но вот искать по заданному списку нигде нет... Но мне вот нужен исходник на ВБ, может подскажите код?

[Ennor]

Н-да, проще селект написать Задача на чистые джойны.

Короче, скорее всего, подход будет циклическим. Бьешь набор слов на массив и каждое по отдельности ищешь в своем тексте. Разбитие строки на массив - Split(), поиск в строке - InStr().

После чего сортируешь свой массив пар слово-частота по второму критерию. Сортировка... ну, посмотри где-нить, хошь в статьях или примерах на этом сайте, хошь - у Кнута Задача довольно простая, это верно...

[alibek]

Код: Выделить всё

Sub FreqDict(ByVal Words As String, ByVal Text As String)
Const vbSpace As String = " ", Separators As String = ".,:;-()_"
Dim W() As String, F() As Long, I0 As Long, I As Long, N As Long, S As String

'Prepare
If Len(Words) = 0 Then Exit Sub
If Len(Text) = 0 Then Exit Sub
If Right$(Words, Len(vbNewLine)) <> vbNewLine Then Words = Words & vbNewLine

'Extracting Words
ReDim W(0)
N = 0
I0 = 1
Do
  I = InStr(I0, Words, vbNewLine)
  If I = 0 Then Exit Do
  N = N + 1
  ReDim Preserve W(0 To N)
  W(N) = UCase$(Mid$(Words, I0, I-I0))
  I0 = I + Len(vbNewLine)
Loop
If N = 0 Then Exit Sub
ReDim F(1 To N)

'Simplife Text
Text = Replace(Text, vbCrLf, vbSpace)
Text = Replace(Text, vbCr, vbSpace)
Text = Replace(Text, vbLf, vbSpace)
For I = 1 To Len(Separators)
  Text = Replace(Text, Mid$(Separators,I,1), vbSpace)
Next I
I = Len(Text)
Do
  Text = Replace(Text, vbSpace & vbSpace, vbSpace)
  If Len(Text) = I Then Exit Do
  I = Len(Text)
Loop
Text = UCase$(Trim$(Text))
If Len(Text) = 0 Then Exit Sub
Text = Text & vbSpace

'Calculate
I0 = 1
Do
  I = InStr(I0, Text, vbSpace)
  If I = 0 Then Exit Do
  S = Mid$(Text, I0, I-I0)
  For N = UBound(W) To 1 Step -1
    If S = W(N) Then Exit For
  Next N
  If N > 0 Then F(N) = F(N) + 1
  I0 = I + Len(vbSpace)
Loop

'Output
For I = 1 To UBound(W)
  Debug.Print W(I) & " - " & F(I)
Next I
End Sub

Сортировку лучше делать не отдельно (между Calculate и Output), а непосредственно в процессе подсчета слов, но мне лень. Пусть это твоим домашним заданием будет.

[Daniil]

'Output
For I = 1 To UBound(W)
Debug.Print W(I) & " - " & F(I)
Next I
End Sub[/code]

Сортировку лучше делать не отдельно (между Calculate и Output), а непосредственно в процессе подсчета слов, но мне лень. Пусть это твоим домашним заданием будет.[/quote]


alibek А не могли бы вы мне прислать исходник? Ведь вы почти уже написали код...... мой майл в подписи....