Выборка из массива

[andrkar]

Нужна помощь! В ворде С помощью макроса получил одномерный массив символьный фиксированной длины. Нужно из него получить другой массив, исключив из исходного массива одинаковые строки. Количество элементов массива заранее неизвестно (получается программно). для завершения программы необходима данная функция. А я в ступоре. Вроде все просто должно быть.
Заранее благодарен

[viter.alex]

Количество элементов в одномерном массиве определяется функцией UBound(массив)

[andrkar]

Может я немного не так написал условие?.. Количество элементов в данном массиве я получаю макросом после некоторой обработки текста. Массив из строк есть, количество элементов в массиве известно. Нужно только исключить из массива одинаковые строки, причем используя не текстовое, а бинарное сравнение строк (то есть используя StrComp)

[Sasha_Smirnov]

В принципе подошёл бы код от Pavel55.

Только тогда надо массив поместить в Excel. Или ту же идею использовать здесь.

[Вождь]

А что мешает еще при создании массива, не добавлять в него одинаковые элементы?

Если строк очень много, то для их хранения и обработки лучше использовать отдельный документ Word.

[andrkar]

согласен, сейчас думаю над тем, как формировать массив без повторений.
вообще полностью задача звучит так - необходимо в текущем документе найти все сокращения (то есть слова состоящие только из заглавных русских или английских букв) и из них сформировать таблицу трех столбцов, в которых - наййденные сокращения без повторения в первом столбце, во всех ячейках второго столбца знак тире, третий столбец пустой.
Кто что посоветует с формирование массива без повторений??

[SAS888]

Кто что посоветует с формирование массива без повторений??

Создайте новую коллекцию и перед занесением очередного элемента в массив, добавляйте этот элемент в коллекцию, перехватывая возможную при этом ошибку. Т.к. двух одинаковых членов коллекции быть не может, то это значит, что если ошибка возникла, то такой элемент уже есть и добавлять его в массив не нужно. Пусть, например, переменная ABCD содержит текущее значение. Тогда:

Dim x As New Collection
On Error Resume Next
x.Add ABCD, CStr(ABCD)
If Err = 0 Then
    'Добавляем в массив
Else
    On Error GoTo 0
End If

Ваш массив не будет содержать повторений. Также, можно использовать словарь.

[viter.alex]

С использованием вспомогательного документа. В результате работы процедуры получим массив с не повторяющимися аббревиатурами. Последний элемент массива будет пустым.

Sub CreateArray()
  Dim oTempDoc As Document
  Dim oWorkDoc As Document
  Dim nPar As Long
  Dim arAbbrs() As String
  
  Set oWorkDoc = ActiveDocument
  Set oTempDoc = Documents.Add(Visible:=False)
  
  'Ищем все аббревиатуры
  With oWorkDoc.Range.Find
    .Text = "<[A-ZА-ЯЁ]@>"
    .MatchWildcards = True
    While .Execute
      'В конец временного документа вставляем найденную аббревиатуру и новый абзац
      oTempDoc.Range.InsertAfter .Parent.Text
      oTempDoc.Range.InsertParagraphAfter
      DoEvents
    Wend
  End With
  
  'Удаляем повторения
  nPar = 1
  While nPar <= oTempDoc.Paragraphs.Count - 1
    With oTempDoc.Range(oTempDoc.Paragraphs(nPar).Range.End, oTempDoc.Range.End).Find
      .Text = oTempDoc.Paragraphs(nPar).Range.Text
      .Replacement.Text = ""
      .Execute Replace:=wdReplaceAll
    End With
    DoEvents
    nPar = nPar + 1
  Wend
  
  'Удаляем два пустых абзаца подряд
  With oTempDoc.Range.Find
    .Text = "^p^p"
    .Execute Replace:=wdReplaceAll
  End With
  
  'Преобразовываем в массив
  arAbbrs = Split(oTempDoc.Range.Text, vbCr)
  
  'Закрываем временный документ без сохранения настроек
  oTempDoc.Close False
End Sub

[tolikman]

Зачем создавать новый документ? чето слишком сложно для такой задачи...
Вместе с ViterAlex'ом можно и так:

Sub CreateArray()
  Dim arAbbrs() As String
  Dim tstr As String, test As Boolean, i As Integer, c As Integer

  c = 0
  'Ищем все аббревиатуры
  With ActiveDocument.Range.Find
    .Text = "<[A-ZА-ЯЁ]@>"
    .MatchWildcards = True

    While .Execute
      tstr = .Parent.Text
      if c > 0 then
         test = true
         for i = 0 to c-1 
            if tstr = arAbbrs(i) then 
              test = false
              exit for
            end if
         next i
         if test then
            redim preserve arAbbrs(c)
            arAbbrs(c)=tstr
            c=c+1
         end if
      else
         redim arAbbrs(0)
         arAbbrs(0) = tstr
         c=c+1
      end if
      DoEvents
    Wend
  End With

и в arAbbrs будет нужный массив... и бдет быстрее работать...

[andrkar]

Option Explicit 'Объявлять переменные
Dim masssokr(1000) As String ' определение массива для найденных строк
--------------------------------------------
это сделано в начале модуля, снаружи функций и подпрограмм.
Далее - функция проверки совпадения элементов и добавления уникального в массив.

Function CheckAdd_STR(STR As String) As Long
Dim I As Long
Static mass_N As Long
For I = 0 To mass_N
If STR = masssokr(I) Then
CheckAdd_STR = mass_N
Exit Function
End If
Next I
masssokr(mass_N) = STR
mass_N = mass_N + 1
CheckAdd_STR = mass_N
End Function
------------------------------------------------------
Ну а теперь собственно сам код поиска сокращений в документе:
Sub Find_Sokr
Dim I As Long
Dim Sokr_N As Long ' число найденных сокращений

Selection.HomeKey Unit:=wdStory 'переходим к началу документа
With Selection.Find 'Задаем условия для поиска
.Text = "<[A-ZА-ЯЁ][A-ZА-ЯЁ]@>" 'комбинация подстановочных знаков,
'позволяющая выбирать слова, состоящие
'только из заглавных русских и английских
'букв
.Forward = True 'направление поиска
.Wrap = wdFindStop 'условие остановки поиска
.MatchWildcards = True 'флаг, включающий использование подстановчных знаков
End With

Do While Selection.Find.Execute = True 'цикл поиска от начала до конца документа
Selection.Find.ClearFormatting
Sokr_N = CheckAdd_STR(Selection.Text) 'Счетчик уникальных элементов в массиве
Loop
End Sub
-----------------------------------------------------------
необходимые данные находятся в массиве
masssokr () размером Sokr_N
Ну а далее уже можно с этими данным делать нужные манипуляции