Во фразах найти слова и продублировать фразы со словами с +

[paradokc]

MS Excel 2013, Windows

Имеется лист с двумя столбцами данных
1-ый столбец слово или словосочетание,
2-ой – число.

Задача такая – нужно найти в первом столбце словосочетания содержащие определенные слова, например, “под” и “для” продублировать эти словосочетания и добавить в них перед искомыми словами знак +.

Массив словосочетаний в первом столбце огромный, перечень слов для замены - “под”, “для” – тоже несколько десятков слов, ручная работа занимает пол дня времени. Подскажите, пожалуйста, как можно решить эту задачку?

Желательно простыми формулами, если нет то макросом.

[Казанский]

многостаночник!
http://www.cyberforum.ru/ms-excel/thread1537004.html
http://www.planetaexcel.ru/forum/ind...y-so-slovami-s

[paradokc]

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

многостаночник!
http://www.cyberforum.ru/ms-excel/thread1537004.html
http://www.planetaexcel.ru/forum/ind...y-so-slovami-s

нельзя спрашивать сразу на нескольких форумах?

[IgorGO]

формально - нельзя (не приветствуется)
но реально - нет механизма, который запретил бы это сделать (нет кооперации между форумами и не будет, видимо)

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

[AleksandrH]

Sub m()
    Dim LastRowA As Integer, LastRowF As Integer
    Dim i As Integer, j As Integer, k As Integer, values As Integer
    Dim key As String, word As String
    LastRowA = ActiveWorkbook.Sheets("Исходник").Range("A65535").End(xlUp).Row
    LastRowF = ActiveWorkbook.Sheets("Исходник").Range("F65535").End(xlUp).Row
    For i = 1 To LastRowA
        For j = 1 To LastRowF
            key = ActiveWorkbook.Sheets("Исходник").Cells(j, 6)
            word = ActiveWorkbook.Sheets("Исходник").Cells(i, 1)
            values = ActiveWorkbook.Sheets("Исходник").Cells(i, 2)
            If InStr(word, key) Then
                k = k + 1
                ActiveWorkbook.Sheets("Результат").Cells(k, 1) = Replace(word, key, "+" & key)
                ActiveWorkbook.Sheets("Результат").Cells(k, 2) = values
            End If
        Next j
    Next i
End Sub

в столбце F листа Исходник размести перечень слов для замены

[svsh2016]

добрый день,попробуйте такой вариант

 Sub example1()
   Dim i&, x()
   x = Sheets("Исходник").UsedRange.Value
     With CreateObject("vbscript.regexp")
              .IgnoreCase = True
              .Pattern = "для"
       For i = 1 To UBound(x)
        If .test(x(i, 1)) Then x(i, 1) = .Replace(x(i, 1), "+для")
       Next
    End With
  Sheets("Результат").Range("A1").Resize(UBound(x), UBound(x, 2)).Value = x
 End Sub

Sub example2()
   Dim i&, x()
   x = Sheets("Результат").UsedRange.Value
        With CreateObject("vbscript.regexp")
              .IgnoreCase = True
              .Pattern = "под"
        For i = 1 To UBound(x)
           If .test(x(i, 1)) Then x(i, 1) = .Replace(x(i, 1), "+под")
        Next
      End With
   Sheets("Результат").Range("A1").Resize(UBound(x), UBound(x, 2)).Value = x
 End Sub

Sub test()
 example1
 example2
 End Sub

[IgorGO]

если слов: для, над, под, слева, справа, между .... будет 1000 шт.
то напишете:

Sub example1()
...
              .Pattern = "для"
... 
End Sub
потом 
Sub example2()
...
              .Pattern = "под"

Sub example3()
...
              .Pattern = "над"
...
...
...

Sub example1000()
...
              .Pattern = "везде!"

может как-то так:

 Sub example(mask as string)
   Dim i&, x()
   x = Sheets("Исходник").UsedRange.Value
     With CreateObject("vbscript.regexp")
              .IgnoreCase = True
              .Pattern = mask
       For i = 1 To UBound(x)
        If .test(x(i, 1)) Then x(i, 1) = .Replace(x(i, 1), "+" & mask)
       Next
    End With
  Sheets("Результат").Range("A1").Resize(UBound(x), UBound(x, 2)).Value = x
 End Sub

[IgorGO]

или вообще создать массив masks, пройтись циклом по массиву 1 раз инициировав CreateObject("vbscript.regexp"), а не для каждого очередного слова.

[svsh2016]

IgorGo,добрый день, я написал для конкретного файл-примера,в предложенном Вами варианте,для этого примера будет так

 Sub example(mask As String)
   Dim i&, x()
   x = Sheets("Исходник").UsedRange.Value
        With CreateObject("vbscript.regexp")
              .IgnoreCase = True
              .Pattern = mask
        For i = 1 To UBound(x)
           If .test(x(i, 1)) Then x(i, 1) = .Replace(x(i, 1), mask)
        Next
      End With
   Sheets("Результат").Range("A1").Resize(UBound(x), UBound(x, 2)).Value = x
 End Sub
 Sub test2()
 example "для"
 example "где"
 End Sub

[paradokc]

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