Макрос для выделения кириллицы в Word

[inspirer161]

Добрый день! нужна ваша помощь, так как с VBA вообще не знаком, а есть очень высокая необходимость создать один макрос для решения задачки. Разбираться нет возможности, времени вообще нету. Готов отблагодарить помощника за 500 рублей (перечислю на кошелёк или на карту Сбера или на телефон)

Вот что нужно:

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

Надеюсь, на помощь и поддержку =)

[shanemac51]

Если нужен документ для тренировки могу скинуть.

образец конечно не помешал бы

[Казанский]

В первом приближении

Sub GetRus()
Dim s$, v
With CreateObject("vbscript.regexp")
  .Global = True
  .Pattern = "[А-ЯЁ-]+"
  .ignorecase = True
  For Each v In .Execute(ActiveDocument.Range)
    s = s & v & vbCrLf
  Next
End With
Documents.Add.Range.InsertAfter s
End Sub

[inspirer161]

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

В первом приближении

Sub GetRus()
Dim s$, v
With CreateObject("vbscript.regexp")
  .Global = True
  .Pattern = "[А-ЯЁ-]+"
  .ignorecase = True
  For Each v In .Execute(ActiveDocument.Range)
    s = s & v & vbCrLf
  Next
End With
Documents.Add.Range.InsertAfter s
End Sub

Спасибо, позже проверю, этого достаточно будет?

[Казанский]

Подправил

Sub GetRus()
Dim s$, v
With CreateObject("vbscript.regexp")
  .Global = True
  .Pattern = "[А-ЯЁ.,; ()-]+"
  .ignorecase = True
  For Each v In .Execute(ActiveDocument.Range)
    v = Trim(v)
    If Right$(v, 1) = ";" Then v = Left(v, Len(v) - 1)
    If Len(v) Then If v <> "-" Then s = s & Trim$(v) & vbCr
  Next
End With
Documents.Add.Range.InsertAfter s
End Sub

[inspirer161]

Спасибо, сегодня днём напишу результат

[inspirer161]

В принципе у тебя всё получилось. Макрос всё на русском языке нашёл, сам перетащил в другой документ,
который открыл сам же и всё расставил. Я проверил макрос на документе-образце.
Всё хорошо, но необходимо внести коррективы.

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

Реально?

[Казанский]

Пробуйте

Sub GetRus()
Dim s$, v
With CreateObject("vbscript.regexp")
  .Global = True
  .Pattern = "[А-ЯЁ.,; ()-]+"
  .ignorecase = True
  For Each v In .Execute(Selection.Range)
    v = Trim(v)
    If Right$(v, 1) = ";" Then v = Left(v, Len(v) - 1)
    If Len(v) Then If v <> "-" Then s = s & Trim$(v) & vbCrLf
  Next
End With
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") 'DataObject
  .SetText s
  .PutInClipboard
End With
MsgBox "Текст помещен в буфер обмена", vbInformation
End Sub

[inspirer161]

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

Пробуйте

Sub GetRus()
Dim s$, v
With CreateObject("vbscript.regexp")
  .Global = True
  .Pattern = "[А-ЯЁ.,; ()-]+"
  .ignorecase = True
  For Each v In .Execute(Selection.Range)
    v = Trim(v)
    If Right$(v, 1) = ";" Then v = Left(v, Len(v) - 1)
    If Len(v) Then If v <> "-" Then s = s & Trim$(v) & vbCrLf
  Next
End With
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") 'DataObject
  .SetText s
  .PutInClipboard
End With
MsgBox "Текст помещен в буфер обмена", vbInformation
End Sub

Макрос, кажется, работает. После его запуска открывается окошечко с запросом разрешения
отправить в буфер обмена. Нажимаю "ОК" , окошечко исчезло, однако вытащить содержание
буфера обмена и вставить его в другом документе не могу. Три варианта вставить копию попробовал, но результата нет.
Может что-то не так делаю?

[Казанский]

Сообщение от inspirer161

После его запуска открывается окошечко с запросом разрешения отправить в буфер обмена.

Интересно. А сообщение "Текст помещен в буфер обмена", которое в предпоследней строке кода, появляется? Или Вы это сообщение имеете в виду?

Сообщение от inspirer161

вытащить содержание
буфера обмена и вставить его в другом документе не могу. Три варианта вставить копию попробовал, но результата нет.
Может что-то не так делаю?

Не знаю, после запуска макроса я нажимаю Ctrl+V в Ворде или Блокноте и получаю текст.
Давайте попробуем проконтролировать в сообщении то, что копируется.
Во вложении - файл с макросом, запуск макроса назначен на сочетание клавиш Alt+Q.