подсчет совпадений!

[Dr.Binom]

Здрасьте! Есть вот такой файл к примеру....

Сергей Антон
Сергей Наташа
Сергей Антон
Сергей Андрей
Сергей Маша
Сергей Миша
Сергей Миша
Сергей Миша
Сергей Наташа

а нужно подсчитать по каждой строке количество совпадений и справа в цифрах показать результат...
т.е. на выходе должно быть так:

Сергей Антон 2
Сергей Наташа 2
Сергей Андрей 1
Сергей Маша 1
Сергей Миша 3

есть идеи? не силен я в вба(

[viter.alex]

Сообщение от Dr.Binom

есть идеи? не силен я в вба(

А в чём силён?
Как тебе такая идея?

Sub MatchesCounter()
    Dim Cnt As Long
    Dim SelStart As Long
'    Перемещение курсора в начало документа
    Selection.HomeKey wdStory
    Do
'        Перемещение курсора в конец строки
        Selection.EndKey wdLine
'        Запоминание положения курсора
        SelStart = Selection.Start
'        Начальное значение счётчика
        Cnt = 1
'        Если строка не пустая, то ищем совпадения
        If Len(Selection.Paragraphs.First.Range.Text) > 1 Then
            With Selection.Find
'                Определение условий поиска
                .ClearFormatting
                .Text = Selection.Paragraphs.First.Range.Text
'                Замена совпадений и одновременный подсчёт
                While .Execute(Replace:=wdReplaceOne)
                    Cnt = Cnt + 1
                Wend
            End With
'            Перемещение курсора на позицию, с которой начали поиск
            Selection.Start = SelStart
'            Снимаем выделение
            Selection.Collapse wdCollapseStart
'            Печатаем результат
            Selection.TypeText vbTab & vbTab & Cnt
        End If
'        Продолжаем пока не закончатся строки
    Loop While Selection.MoveDown(wdLine) <> 0
End Sub

С предложенным примером работает на ура

[Dr.Binom]

Для начала,спасибо огромное за помощь! НО...
я забыл указать деталь одну...

просто я уже написал макрос который обрабатывает доковский файл, и вытаскивает из таблицы собственно вот эти имена...
файл изначально устроен так:
идет текст, потом таблицы , текст и т.д., а потом нужная таблица с именами адресами и т.д.
так вот, я написал макрос, который просто находит эти имена из нужной таблицы и пишет их в таком порядке как указанно выше уже в текстовый файл......

вопрос: можно как нить изменить код,чтобы макрос открывал этот текстовый файл и делал то же самое, только в тхт файле? или проще как то изменить мой код,чтобы он сразу делал и то и то?

простите, если непонятно изъясняюсь)

[Казанский]

Лучше, конечно, дописать тот макрос, чтобы исключить лишние действия с текстовым файлом. Но за неимением оного предлагаю макрос, работающий с текстовым файлом. Подсчет одинаковых строк удобно делать на словаре.

Sub bb()
Dim s
Open "d:\Dr.Binom.txt" For Input As #1 'путь к файлу
With CreateObject("scripting.dictionary")
    Do Until EOF(1)
        Line Input #1, s
        .Item(s) = .Item(s) + 1
    Loop
    Close #1
    For Each s In .keys
        Selection.InsertAfter s & " " & .Item(s) & vbCrLf
    Next
End With
End Sub

... А Сергей-то у нас бисексуал

[Dr.Binom]

Сообщение от Казанский

Но за неимением оного предлагаю макрос, работающий с текстовым файлом.

СПАСИБО за помощь! но нужно тчобы результат был в текстовом файле...может так лучше будет: вот этот макрос, корявый конечно) но что есть...
Предварительно поясню, в документе встречается вот такое:

блаблаблабалабал *СЕРГЕЙ:
и ниже таблица тех, с кем он "общался" например
мы просто находим расположение Сергея, добавляем в нижнюю таблицу новый столбец, а в него вставляем Сергей. тем самым получаем вот это:
Сергей Антон
Сергей Наташа
Сергей Антон
Сергей Андрей
Сергей Маша
Сергей Миша
Сергей Миша
Сергей Миша
Сергей Наташа
и записываем в текстовый файл построчно.*
может теперь проще как нибудь изменить этот макрос, чтобы сразу еще и считались совпадения?

Sub FindTables()

      Dim tTable As Table
      Open "F:\test.txt" For Append As #1
      linew = ""
      For Each tTable In ActiveDocument.Tables
    
      tTable.Cell(1, 1).Select
      stext = Selection.Text
   

   
   
If (Mid(stext, 1, 3) = "Имя") Then 'ищет таблицу с первым столбцом Имя. (в документе много таблиц, надо пройтись по всем такого образца)
      
    
     Selection.MoveUp Count:=2
     Selection.MoveRight Count:=1
     
   
     
   With Selection.Find
        .Text = ""
        .Font.Bold = True
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute    'после этого вырезается имя "Сергей" (расположено чуть выше таблицы)
   
    
     
     Selection.Copy
     Selection.MoveLeft Count:=30
     Selection.MoveDown Count:=2
     Selection.InsertColumns
     tTable.Rows(1).Delete         'удаляем 1 строку таблицы
     tTable.Columns(1).Select    
     rw = tTable.Rows.Count
     Selection.Paste               'вставляем имя Сергей в добавленный столбец
     Selection.ClearFormatting  'убираем форматирование (имя жирным цветом идет)
     tTable.ConvertToText Separator:=wdSeparateByTabs   'убираем границы таблицы
     
     Selection.MoveStart wdLine, 0
     
     For i = 1 To rw  'построчно записываем в тхт файл полученную таблицу
     Selection.MoveEnd wdLine, 1
     linew = linew + Selection.Text
    
    Print #1, Selection.Text
    Selection.EndOf
    Next i
   
End If
      
   'Print #1, linew
      Next
      
       Close #1
   End Sub

[Казанский]

Приложите пример файла. В таблице изначально один столбец?

[Dr.Binom]

Сообщение от Казанский

Приложите пример файла. В таблице изначально один столбец?

вот пример файла. я немного подкорректировал макрос, чтобы он теперь удалял ненужные столбцы, а оставлял только новый добавленный с именем Сергей и Коррсепондентами.
вот как было:

[Dr.Binom]

Сообщение от Казанский

Приложите пример файла. В таблице изначально один столбец?

вот так стало:

[Казанский]

> вот пример файла.
Это не пример файла. Это картинка. Чтобы "как нибудь изменить" существующий макрос (а лучше написать новый) надо иметь файл DOC с таблицей, у которой в первой ячейке есть "Имя" и пр.
При каждом запуске макроса следует дописывать информацию в один и тот же файл (Open "F:\test.txt" For Append As #1) или как-то по-другому (например, создавать новый текстовый файл в той же папке с тем же именем, запрашивать имя у пользователя)?

[Niki12]

Добрый день! Я вот тоже не знаю VBA , но на работе нужно постоянно делать такую операцию: имеется таблица в Wordе с одним столбцом,в ячейках которого записаны текстовые фразы,и во многих ячейках они повторяются.Нужно удалить повторяющиеся ячейки этого столбца,оставив естессно уникальные.Например,есть столбец

маша сестра
коля брат
гена зять
коля брат
маша сестра
коля брат
нужно оставить только строки

маша сестра
коля брат
гена зять
Очень прошу помощи! Спасибо.Файл для примера прилагаю.