Во фразах найти слова и продублировать фразы со словами с + - Microsoft Office Excel - Страница 2

paradokc · 25.09.2015, 15:05

Цитата:

Сообщение от 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 · 25.09.2015, 15:12

Цитата:

Сообщение от 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 · 25.09.2015, 15:30

Цитата:

Сообщение от 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 · 25.09.2015, 16:03

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

Код:

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 · 25.09.2015, 17:53

добрый вечер, в предыдущем файл -примере имеется пользовательская функция 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 · 25.09.2015, 21:43

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

Код:

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 · 26.09.2015, 23:11

доброго времени суток,в развитие варианта,предложенного 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 · 27.09.2015, 11:00

добрый день,чтобы завершить тему на положительном настрое,-имеется еще вариант, 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 · 28.09.2015, 09:45

Цитата:

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

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

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

paradokc · 28.09.2015, 10:06

Цитата:

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

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

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

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

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

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

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

25.09.2015, 17:53	#15
svsh2016 Форумчанин Регистрация: 16.06.2015 Сообщений: 100	добрый вечер, в предыдущем файл -примере имеется пользовательская функция 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`

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
В текстовом файле найти все слова, совпадающие с заданным пользователем и поменять их местами с соседними справа словами ( c# )	CROWN	Помощь студентам	4	24.12.2014 15:57
Найти в memo определёные фразы	maks5	Общие вопросы Delphi	2	23.09.2011 16:41
Символьная строка содержит слова, разделенные пробелами. Найти все слова-палиндромы (Паскаль)	sashunechka	Помощь студентам	4	18.05.2011 21:45
Поиск последнего слова фразы в дереве предложения.	the_deer_one	Свободное общение	5	17.08.2010 14:48
Дано предложение. Между словами предложения один пробел, а после последнего слова точка.	Vadim123456	Помощь студентам	0	01.05.2010 23:28