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

[paradokc]

Сообщение от 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 листа Исходник размести перечень слов для замены

Работает! Супер! Спасибо!

[paradokc]

Сообщение от 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

...
.Pattern = "везде!"[/CODE]может как-то так:

 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

Спасибо большое за ответ!
К сожалению вот тут уже как-то мне тяжеловато представить что надо делать для расширения списка.
Тем более не знаю такой, видимо очень классной, штуки как маски и CreateObject("vbscript.regexp").
Но я все равно Вас благодарю.

[paradokc]

Сообщение от 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 листа Исходник размести перечень слов для замены

Есть баг: если в столбце F будут такие предлоги как например "по" или "с", то макрос разрывает плюсами слова.
Как-то можно дополнить его, чтобы он учитывал слова в столбце F только как целые?
т.е. при наличии в столбце F слова "с", а в таблице фразы

стакан
стакан с ручкой
с ручкой кружка
автомобиль тип с

в итоге + добавился только во фразах 2, 3, 4

стакан
стакан +с ручкой
+с ручкой кружка
стрела тип +с

[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) = Trim(Replace(word, key, " +" & LTrim(key)))
                ActiveWorkbook.Sheets("Результат").Cells(k, 2) = values
            End If
        Next j
    Next i
End Sub

[svsh2016]

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

 Function zz(t1$, mask As Range)
     Dim x: x = Application.Transpose(mask.Value)
  With CreateObject("vbscript.regexp")
      .Global = True
      .IgnoreCase = True
      .Pattern = Join(x, "|")
    If .test(t1) Then zz = .Execute(t1)(0).Value Else zz = ""
  End With
End Function

[svsh2016]

добрый вечер,вышеуказанные формулы заносим в диапазон переменного размера макросом:

Sub incert_formulas()
    Dim i&, i1&, i2&
    i1 = Sheets("Исходник").Range("A" & Cells.Rows.Count).End(xlUp).Row
    i2 = Sheets("Исходник").Range("F" & Cells.Rows.Count).End(xlUp).Row
  For i = 1 To i1
 Range("D" & i).Formula = "=zz(Исходник!A" & i & ",Исходник!F1:F" & i2 & ")"
 Range("C" & i).Formula = _
        "=IF(D" & i & "="""","""",SUBSTITUTE(Исходник!A" & i & ",Результат!D" & i & ",""+"" & Результат!D" & i & "))"
 Next
End Sub

[svsh2016]

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

Sub replica1(mask As Range)
   Dim i&, x(), x1(), m&, j&
   x1 = Application.Transpose(mask.Value)
   x = Sheets("Исходник").UsedRange.Value
        With CreateObject("vbscript.regexp")
              .ignorecase = True
              .Pattern = Join(x1, "|")
        For i = 1 To UBound(x)
           If .test(x(i, 1)) Then
           m = m + 1: For j = 2 To UBound(x, 2): x(m, j) = x(i, j): Next
            x(m, 1) = .Replace(x(i, 1), "+" & .Execute(x(i, 1))(0).Value)
            End If
        Next
      End With
   Sheets("Результат").Range("A1").Resize(m, UBound(x, 2)).Value = x
 End Sub

Sub use1()
 Dim i1&
 i1 = Sheets("Исходник").Range("F" & Cells.Rows.Count).End(xlUp).Row
 replica1 Sheets("Исходник").Range("F1:F" & i1)
  Sheets("Результат").Columns("F:F").ClearContents
 End Sub

вторая пара:

Sub replica(mask As Range)
   Dim i&, x(), x1()
   x1 = Application.Transpose(mask.Value)
   x = Sheets("Исходник").UsedRange.Value
        With CreateObject("vbscript.regexp")
              .ignorecase = True
              .Pattern = Join(x1, "|")
        For i = 1 To UBound(x)
           If .test(x(i, 1)) Then x(i, 1) = .Replace(x(i, 1), "+" & .Execute(x(i, 1))(0).Value)
        Next
      End With
   Sheets("Результат").Range("A1").Resize(UBound(x), UBound(x, 2)).Value = x
 End Sub

 Sub use()
 Dim i1&
 i1 = Sheets("Исходник").Range("F" & Cells.Rows.Count).End(xlUp).Row
 replica Sheets("Исходник").Range("F1:F" & i1)
  Sheets("Результат").Columns("F:F").ClearContents
 End Sub

[svsh2016]

добрый день,чтобы завершить тему на положительном настрое,-имеется еще вариант, use2,выводящий данные в первоначально, предложенном формате создателя темы( также красная кнопка, use2 ,в файл - примере)
С уважением ко всем участникам обсуждения.

Sub replica2(mask As Range)
   Dim i&, x(), x2(), x1(), m&, n&, j&, k&
   x1 = Application.Transpose(mask.Value)
   x = Sheets("Исходник").UsedRange.Value
   ReDim x2(1 To UBound(x), 1 To UBound(x, 2))
        With CreateObject("vbscript.regexp")
              .ignorecase = True
              .Pattern = Join(x1, "|")
        For i = 1 To UBound(x)
           If .test(x(i, 1)) Then
           m = m + 1: For j = 2 To UBound(x, 2): x(m, j) = x(i, j): Next
            x(m, 1) = .Replace(x(i, 1), "+" & .Execute(x(i, 1))(0).Value)
            Else
            n = n + 1: For k = 1 To UBound(x, 2): x2(n, k) = x(i, k): Next
            End If
        Next
      End With
   Sheets("Результат").Range("A1").Resize(n, UBound(x, 2)).Value = x2
   Sheets("Результат").Range("A" & n + 1).Resize(m, UBound(x, 2)).Value = x
 End Sub

Sub use2()
 Dim i1&
 i1 = Sheets("Исходник").Range("F" & Cells.Rows.Count).End(xlUp).Row
 replica2 Sheets("Исходник").Range("F1:F" & i1)
  Sheets("Результат").Columns("F:F").ClearContents
 End Sub

[paradokc]

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

натыкал костылей

Доброе утро! Работает, спасибо!

[paradokc]

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

добрый день,чтобы завершить тему на положительном настрое,-имеется еще вариант, use2,выводящий данные в первоначально, предложенном формате создателя темы( также красная кнопка, use2 ,в файл - примере)
С уважением ко всем участникам обсуждения.

Проверил все предложенные варианты. Все рабочие, но с замечаниями
1. красные кнопки отрабатывают от начала строки.
например,
"авто то" получается
"ав+то то".

2. кнопка incert_formulas отрабатывает до конца строки, но разрывает слова при нахождении слога подходящего под условие
"авто то" - > "ав+то +то"

3. И вопрос с массивами mask. Не разобрался с этим пунктом.

За сим сердечно благодарю за старания.
Вариант от AleksandrH с костылями - отрабатывает отлично без необходимости дорабатывать код или погружаться в VBA.

Но, думаю, что юзерам более продвинутым, чем я понадобится и Ваш вариант.