поиск совпадений слов в тексте - Мир MS Excel

Регистрация

Напомнить пароль

= Мир MS Excel/поиск совпадений слов в тексте - Мир MS Excel

Старая форма входа

Страница 1 из 2 1 2 »
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » поиск совпадений слов в тексте (Макросы Sub)

поиск совпадений слов в тексте

Дата: Четверг, 24.10.2013, 08:52 | Сообщение № 1

Группа: Пользователи

Ранг: Новичок

Сообщений: 17

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

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

также можно выбирать копирование только в определенные столбцы, а в строки - нет, над этим думаю сам, но вдруг у кого етсь мысли

К сообщению приложен файл: _v_2.xlsm (21.3 Kb)

Ответить

Дата: Четверг, 24.10.2013, 10:00 | Сообщение № 2

Группа: Авторы

Ранг: Старожил

Сообщений: 1613

Репутация: 563 ±

Замечаний: 0% ±

Excel 2013, 2016

Привет, Akost100
на Лист1 запишите в столбце С
ест
принимает
идет
...

и попробуйте вот так:
[vba]

Код

Sub Поискикопирование()
Dim strStartAddr As String
Dim rgResult As Range
Dim arrSearchWords
Dim i As Long
arrSearchWords = Range("C1", Cells(Rows.Count, 3).End(xlUp)).Value
With Range("A1", Cells(Rows.Count, 1).End(xlUp))
     For i = 1 To UBound(arrSearchWords)
         Set rgResult = .Find(arrSearchWords(i, 1))
         If Not rgResult Is Nothing Then
             strStartAddr = rgResult.Address
             Do
                 Sheets(2).Cells(Sheets(2).Rows.Count, 5).End(xlUp)(2) = rgResult
                 Set rgResult = .FindNext(rgResult)
                 If rgResult.Address = strStartAddr Then Exit Do
             Loop
         End If
     Next i
End With
End Sub

[/vba]

Яндекс.Деньги 4100159601573

Ответить

Дата: Пятница, 25.10.2013, 17:56 | Сообщение № 3

Группа: Пользователи

Ранг: Новичок

Сообщений: 17

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

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

Ответить

Дата: Пятница, 25.10.2013, 18:05 | Сообщение № 4

Группа: Друзья

Ранг: Старожил

Сообщений: 1206

Репутация: 255 ±

Замечаний: 0% ±

2010

Кросс
http://www.planetaexcel.ru/forum....D=52090

skypro1111@gmail.com

Ответить

Дата: Пятница, 25.10.2013, 18:09 | Сообщение № 5

Группа: Авторы

Ранг: Старожил

Сообщений: 1613

Репутация: 563 ±

Замечаний: 0% ±

Excel 2013, 2016

Akost100,
показали бы файлик с примером, может чего и придумали бы, как бы

[offtop]ПС как правильно пишется "как бы"? прям вот так?[/offtop]

Яндекс.Деньги 4100159601573

Ответить

Дата: Пятница, 25.10.2013, 19:05 | Сообщение № 6

Группа: Пользователи

Ранг: Новичок

Сообщений: 17

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

пожалуйста

К сообщению приложен файл: 4098839.xlsm (24.0 Kb)

Ответить

Дата: Пятница, 25.10.2013, 19:35 | Сообщение № 7

Группа: Авторы

Ранг: Старожил

Сообщений: 1613

Репутация: 563 ±

Замечаний: 0% ±

Excel 2013, 2016

давайте попробуем через ertert
[vba]

Код

Sub ertert()
Dim x, i&, j&, r As Range, adr As String, sp
Sheets("Лист1").Activate
x = Range("C1:D" & Cells(Rows.Count, 3).End(xlUp).Row).Value
With Range("A1", Cells(Rows.Count, 1).End(xlUp))
     For i = 1 To UBound(x)
         Set r = .Find(x(i, 1))
         If Not r Is Nothing Then
             adr = r.Address
             Do
                 x(i, 2) = x(i, 2) & "~" & r
                 Set r = .FindNext(r)
             Loop While r.Address <> adr
         End If
     Next i
End With
With Sheets("Лист4")
     For i = 1 To UBound(x)
         With .Cells(Rows.Count, 1).End(xlUp)(3)
             .Value = x(i, 1)
             sp = Split(Mid(x(i, 2), 2), "~")
             .Cells(2).Resize(UBound(sp) + 1).Value = Application.Transpose(sp)
         End With
     Next i
     .Activate
End With
End Sub

[/vba]
все, идемте Голос смотреть

Яндекс.Деньги 4100159601573

Ответить

Дата: Пятница, 25.10.2013, 21:35 | Сообщение № 8

Группа: Проверенные

Ранг: Старожил

Сообщений: 2369

Репутация: 486 ±

Замечаний: 0% ±

2003-2010

Задолбали!
http://www.excel-vba.ru/forum/index.php?topic=2477.msg12922#new

Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728

Ответить

Дата: Пятница, 25.10.2013, 21:53 | Сообщение № 9

Группа: Друзья

Ранг: Экселист

Сообщений: 5660

Репутация: 1163 ±

Замечаний: 0% ±

2010

Цитата KuklP, 25.10.2013 в 21:35, в сообщении № 8

Задолбали!

Спокойствие. Только спокойствие...

Быть или не быть, вот в чем загвоздка!

Ответить

Дата: Воскресенье, 27.10.2013, 07:08 | Сообщение № 10

Группа: Пользователи

Ранг: Новичок

Сообщений: 17

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

спасибо, nilem, подскажите еще пожалуйста, как строки, в которых будет находится первое слово обрамить в рамку, ведь у этих строк будет постоянно разный адрес - в файле, т.е хотелось бы, чтобы только имена были в рамке, а остальное то что ниже - без, т.е на листе 2 - как получилось, а на листе 3 - как бы хотелось

К сообщению приложен файл: 9264923.xlsm (64.4 Kb)

Ответить

Дата: Воскресенье, 27.10.2013, 07:51 | Сообщение № 11

Группа: Пользователи

Ранг: Новичок

Сообщений: 17

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

и еще вопрос, поскольку я пытаюсь разобраться, вот это:
Dim x, i&, j&, r As Range, adr As String, sp

с таким еще не сталкивался просто, x,i,j поясните пожалуйста, что-то на координаты векторов похоже
adr,sp - тоже что такое
если время будет конечно

Ответить

Дата: Воскресенье, 27.10.2013, 07:54 | Сообщение № 12

Группа: Авторы

Ранг: Старожил

Сообщений: 1613

Репутация: 563 ±

Замечаний: 0% ±

Excel 2013, 2016

пробуйте
[vba]

Код

Sub ertert()
Dim x, i&, j&, r As Range, adr As String, sp
Sheets("Лист1").Activate
x = Range("C1:D" & Cells(Rows.Count, 3).End(xlUp).Row).Value
With Range("A1", Cells(Rows.Count, 1).End(xlUp))
     For i = 1 To UBound(x)
         Set r = .Find(x(i, 1))
         If Not r Is Nothing Then
             adr = r.Address
             Do
                 x(i, 2) = x(i, 2) & "~" & r
                 Set r = .FindNext(r)
             Loop While r.Address <> adr
         End If
     Next i
End With
With Sheets("Лист4")
     For i = 1 To UBound(x)
         With .Cells(Rows.Count, 1).End(xlUp)(3)
             .Value = x(i, 1)
             .Resize(, 22).Borders.Weight = xlMedium
             sp = Split(Mid(x(i, 2), 2), "~")
             With .Cells(2).Resize(UBound(sp) + 1)
                 .Value = Application.Transpose(sp)
                 .Resize(UBound(sp) + 2, 22).Borders.LineStyle = xlContinuous
                 .Resize(UBound(sp) + 2, 22).Borders.Item(xlInsideHorizontal).LineStyle = xlLineStyleNone
             End With
         End With
     Next i
     .Activate
End With
End Sub

[/vba]

Яндекс.Деньги 4100159601573

Ответить

Дата: Воскресенье, 27.10.2013, 07:59 | Сообщение № 13

Группа: Авторы

Ранг: Старожил

Сообщений: 1613

Репутация: 563 ±

Замечаний: 0% ±

Excel 2013, 2016

Dim x, i&, j&, r As Range, adr As String, sp
это строка объявления переменных, а крючки & - то же самое, что As Long
почитайте справку ВБА и еще книжку какую-нибудь (здесь на сайте есть раздел литература)

Яндекс.Деньги 4100159601573

Ответить

Дата: Вторник, 29.10.2013, 08:23 | Сообщение № 14

Группа: Пользователи

Ранг: Новичок

Сообщений: 17

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

подскажите еще как убрать слова до ключевого слова, в файле на листе 4 как получается сейчас, а в следующих двух листах - как хотелось бы

К сообщению приложен файл: 5813911.xlsm (69.0 Kb)

Ответить

Дата: Вторник, 29.10.2013, 12:29 | Сообщение № 15

Группа: Авторы

Ранг: Старожил

Сообщений: 1613

Репутация: 563 ±

Замечаний: 0% ±

Excel 2013, 2016

пробуем:
[vba]

Код

Sub ertert22()
Dim x, i&, j&, r As Range, adr As String, sp
Sheets("Лист1").Activate
x = Range("C1:D" & Cells(Rows.Count, 3).End(xlUp).Row).Value
With Range("A1", Cells(Rows.Count, 1).End(xlUp))
     For i = 1 To UBound(x)
         Set r = .Find(x(i, 1))
         If Not r Is Nothing Then
             adr = r.Address
             Do
                 x(i, 2) = x(i, 2) & "~" & r
                 Set r = .FindNext(r)
             Loop While r.Address <> adr
         End If
     Next i
End With
With Sheets("Лист4")
     For i = 1 To UBound(x)
         With .Cells(Rows.Count, 1).End(xlUp)(3)
             .Value = x(i, 1)
             .Resize(, 22).Borders.Weight = xlMedium
             If InStr(x(i, 2), "~") Then
                 sp = Split(Mid(x(i, 2), 2), "~")
                 For j = 0 To UBound(sp)
                     sp(j) = x(i, 1) & Split(sp(j), x(i, 1))(1)
                 Next j
                 With .Cells(2).Resize(UBound(sp) + 1)
                     .Value = Application.Transpose(sp)
                     .Resize(UBound(sp) + 2, 22).Borders.LineStyle = xlContinuous
                     .Resize(UBound(sp) + 2, 22).Borders.Item(xlInsideHorizontal).LineStyle = xlLineStyleNone
                 End With
             End If
         End With
     Next i
     .Activate
End With
End Sub

[/vba]

Яндекс.Деньги 4100159601573

Ответить

Дата: Среда, 30.10.2013, 08:33 | Сообщение № 16

Группа: Пользователи

Ранг: Новичок

Сообщений: 17

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

спасибо

Ответить

Дата: Понедельник, 04.11.2013, 08:38 | Сообщение № 17

Группа: Пользователи

Ранг: Новичок

Сообщений: 17

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

да, но как убрать из результата то, чего нет в столбце А, на листе 4 - то, что получается, а на следующем как хотелось бы

К сообщению приложен файл: 3799147.xlsm (59.2 Kb)

Ответить

Дата: Понедельник, 04.11.2013, 09:25 | Сообщение № 18

Группа: Авторы

Ранг: Старожил

Сообщений: 1613

Репутация: 563 ±

Замечаний: 0% ±

Excel 2013, 2016

[vba]

Код

Sub ertert33()
Dim x, i&, j&, r As Range, adr As String, sp
Sheets("Лист1").Activate
x = Range("C1:D" & Cells(Rows.Count, 3).End(xlUp).Row).Value
With Range("A1", Cells(Rows.Count, 1).End(xlUp))
     For i = 1 To UBound(x)
         Set r = .Find(x(i, 1))
         If Not r Is Nothing Then
             adr = r.Address
             Do
                 x(i, 2) = x(i, 2) & "~" & r
                 Set r = .FindNext(r)
             Loop While r.Address <> adr
         End If
     Next i
End With
With Sheets("Лист4")
     For i = 1 To UBound(x)
         With .Cells(Rows.Count, 1).End(xlUp)(3)
             If InStr(x(i, 2), "~") Then
                 .Value = x(i, 1)
                 .Resize(, 22).Borders.Weight = xlMedium
                 sp = Split(Mid(x(i, 2), 2), "~")
                 For j = 0 To UBound(sp)
                     sp(j) = x(i, 1) & Split(sp(j), x(i, 1))(1)
                 Next j
                 With .Cells(2).Resize(UBound(sp) + 1)
                     .Value = Application.Transpose(sp)
                     .Resize(UBound(sp) + 2, 22).Borders.LineStyle = xlContinuous
                     .Resize(UBound(sp) + 2, 22).Borders.Item(xlInsideHorizontal).LineStyle = xlLineStyleNone
                 End With
             End If
         End With
     Next i
     .Activate
End With
End Sub

[/vba]

Яндекс.Деньги 4100159601573

Ответить

Дата: Пятница, 08.11.2013, 09:02 | Сообщение № 19

Группа: Пользователи

Ранг: Новичок

Сообщений: 17

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

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

К сообщению приложен файл: 6415517.xlsm (60.2 Kb)

Ответить

Дата: Пятница, 08.11.2013, 09:57 | Сообщение № 20

Группа: Авторы

Ранг: Старожил

Сообщений: 1613

Репутация: 563 ±

Замечаний: 0% ±

Excel 2013, 2016

вот
[vba]

Код

Sub ertert22_2()
Dim x, i&, j&, r As Range, adr As String, sp: Application.ScreenUpdating = False
Sheets("Лист1").Activate
x = Range("C1:D" & Cells(Rows.Count, 3).End(xlUp).Row).Value
With Range("A1", Cells(Rows.Count, 1).End(xlUp))
     For i = 1 To UBound(x)
         Set r = .Find(x(i, 1))
         If Not r Is Nothing Then
             adr = r.Address
             Do
                 x(i, 2) = x(i, 2) & "~" & r
                 Set r = .FindNext(r)
             Loop While r.Address <> adr
         End If
     Next i
End With
With Sheets("Лист4")
     For i = 1 To UBound(x)
         With .Cells(Rows.Count, 1).End(xlUp)(3)
             .Value = x(i, 1)
             .Resize(, 22).Borders.Weight = xlThin
             If InStr(x(i, 2), "~") Then
                 sp = Split(Mid(x(i, 2), 2), "~")
                 For j = 0 To UBound(sp)
                     sp(j) = x(i, 1) & Split(sp(j), x(i, 1))(1)
                 Next j
                 With .Cells(2).Resize(UBound(sp) + 1)
                     .Value = Application.Transpose(sp)
                     .Resize(UBound(sp) + 2, 22).Borders.LineStyle = xlContinuous
                     .Resize(UBound(sp) + 2, 22).Borders.Item(xlInsideHorizontal).LineStyle = xlLineStyleNone
                 End With
                 .Item(1, 4).FormulaR1C1 = "=SUM(R[1]C:R[" & UBound(sp) + 1 & "]C)"
             End If
         End With
     Next i
     .Activate
End With: Application.ScreenUpdating = True
End Sub

[/vba]

Цитата Akost100, 08.11.2013 в 09:02, в сообщении № 19

результатов мароса выше ertret22

правильно ertert (разница принципиальная :))

вот
[vba]

Код

Sub ertert22_2()
Dim x, i&, j&, r As Range, adr As String, sp: Application.ScreenUpdating = False
Sheets("Лист1").Activate
x = Range("C1:D" & Cells(Rows.Count, 3).End(xlUp).Row).Value
With Range("A1", Cells(Rows.Count, 1).End(xlUp))
     For i = 1 To UBound(x)
         Set r = .Find(x(i, 1))
         If Not r Is Nothing Then
             adr = r.Address
             Do
                 x(i, 2) = x(i, 2) & "~" & r
                 Set r = .FindNext(r)
             Loop While r.Address <> adr
         End If
     Next i
End With
With Sheets("Лист4")
     For i = 1 To UBound(x)
         With .Cells(Rows.Count, 1).End(xlUp)(3)
             .Value = x(i, 1)
             .Resize(, 22).Borders.Weight = xlThin
             If InStr(x(i, 2), "~") Then
                 sp = Split(Mid(x(i, 2), 2), "~")
                 For j = 0 To UBound(sp)
                     sp(j) = x(i, 1) & Split(sp(j), x(i, 1))(1)
                 Next j
                 With .Cells(2).Resize(UBound(sp) + 1)
                     .Value = Application.Transpose(sp)
                     .Resize(UBound(sp) + 2, 22).Borders.LineStyle = xlContinuous
                     .Resize(UBound(sp) + 2, 22).Borders.Item(xlInsideHorizontal).LineStyle = xlLineStyleNone
                 End With
                 .Item(1, 4).FormulaR1C1 = "=SUM(R[1]C:R[" & UBound(sp) + 1 & "]C)"
             End If
         End With
     Next i
     .Activate
End With: Application.ScreenUpdating = True
End Sub

[/vba]

Цитата Akost100, 08.11.2013 в 09:02, в сообщении № 19

результатов мароса выше ertret22

правильно ertert (разница принципиальная :))nilem

Яндекс.Деньги 4100159601573

Ответить

Сообщениевот
[vba]

Код

Sub ertert22_2()
Dim x, i&, j&, r As Range, adr As String, sp: Application.ScreenUpdating = False
Sheets("Лист1").Activate
x = Range("C1:D" & Cells(Rows.Count, 3).End(xlUp).Row).Value
With Range("A1", Cells(Rows.Count, 1).End(xlUp))
     For i = 1 To UBound(x)
         Set r = .Find(x(i, 1))
         If Not r Is Nothing Then
             adr = r.Address
             Do
                 x(i, 2) = x(i, 2) & "~" & r
                 Set r = .FindNext(r)
             Loop While r.Address <> adr
         End If
     Next i
End With
With Sheets("Лист4")
     For i = 1 To UBound(x)
         With .Cells(Rows.Count, 1).End(xlUp)(3)
             .Value = x(i, 1)
             .Resize(, 22).Borders.Weight = xlThin
             If InStr(x(i, 2), "~") Then
                 sp = Split(Mid(x(i, 2), 2), "~")
                 For j = 0 To UBound(sp)
                     sp(j) = x(i, 1) & Split(sp(j), x(i, 1))(1)
                 Next j
                 With .Cells(2).Resize(UBound(sp) + 1)
                     .Value = Application.Transpose(sp)
                     .Resize(UBound(sp) + 2, 22).Borders.LineStyle = xlContinuous
                     .Resize(UBound(sp) + 2, 22).Borders.Item(xlInsideHorizontal).LineStyle = xlLineStyleNone
                 End With
                 .Item(1, 4).FormulaR1C1 = "=SUM(R[1]C:R[" & UBound(sp) + 1 & "]C)"
             End If
         End With
     Next i
     .Activate
End With: Application.ScreenUpdating = True
End Sub

[/vba]

Цитата Akost100, 08.11.2013 в 09:02, в сообщении № 19

результатов мароса выше ertret22

правильно ertert (разница принципиальная :))

Автор - nilem
Дата добавления - 08.11.2013 в 09:57

Мир MS Excel » Вопросы и решения » Вопросы по VBA » поиск совпадений слов в тексте (Макросы Sub)

Страница 1 из 2
1
2
»

© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!