Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

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

 

= Мир MS Excel/Доделать макрос поиска слов в фразах - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Доделать макрос поиска слов в фразах (Макросы/Sub)
Доделать макрос поиска слов в фразах
lybashevv Дата: Понедельник, 28.11.2016, 13:47 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 1
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Здравствуйте помогите пожалуйста доделать макрос.
У меня есть макрос, который делает то что мне нужно, но не до конца.

Основной смысл, для чего мне макрос:
- есть 1 колонка со словами
- есть 2 колонка с фразами
- нужно найти фразы из 2 колонки в которых есть слова из 1 колонки
- и расположить фразы в которых содержится слово, напротив этого слова, таким образом как показано в примере

То что нужно доделать:
- слово и фраза, в которой оно найдено, были напротив друг друга,
- а напротив остальных фраз, в которых найдено слово(если фраза не одна), в 1 колонке была бы пустая ячейка
- и напротив слова из 1 столбца, которое не содержится ни в одной фразе из 2, была пустая ячейка в колонке 2

Код макроса:
[vba]
Код
Sub FindWords()
Dim fl As Boolean
Dim arrTemp2()
Dim arrTemp1()
    arrW = Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row).Value
    arrPh = Range("D2 <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=" <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=":D" /> " /> " & Cells(Rows.Count, "D").End(xlUp).Row).Value
    For I = 1 To UBound(arrPh)
        fl = False
        For J = 1 To UBound(arrW)
            If arrPh(I, 1) Like "*" & arrW(J, 1) & "*" Then
                ReDim Preserve arrTemp1(I)
                arrTemp1(I) = arrPh(I, 1)
                fl = True
                Exit For
            End If
        Next
        If Not fl Then
            N = N + 1
            ReDim Preserve arrTemp2(N)
            arrTemp2(N) = arrPh(I, 1)
        End If
    Next
    Columns("D").ClearContents
    Range("D1").Resize(UBound(arrTemp1) + 1) = Application.Transpose(arrTemp1)
    Columns("F").ClearContents
    Range("F1").Resize(UBound(arrTemp2) + 1) = Application.Transpose(arrTemp2)
End Sub
[/vba]
К сообщению приложен файл: -___.xlsm(17Kb)


Сообщение отредактировал lybashevv - Понедельник, 28.11.2016, 15:26
 
Ответить
СообщениеЗдравствуйте помогите пожалуйста доделать макрос.
У меня есть макрос, который делает то что мне нужно, но не до конца.

Основной смысл, для чего мне макрос:
- есть 1 колонка со словами
- есть 2 колонка с фразами
- нужно найти фразы из 2 колонки в которых есть слова из 1 колонки
- и расположить фразы в которых содержится слово, напротив этого слова, таким образом как показано в примере

То что нужно доделать:
- слово и фраза, в которой оно найдено, были напротив друг друга,
- а напротив остальных фраз, в которых найдено слово(если фраза не одна), в 1 колонке была бы пустая ячейка
- и напротив слова из 1 столбца, которое не содержится ни в одной фразе из 2, была пустая ячейка в колонке 2

Код макроса:
[vba]
Код
Sub FindWords()
Dim fl As Boolean
Dim arrTemp2()
Dim arrTemp1()
    arrW = Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row).Value
    arrPh = Range("D2 <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=" <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=":D" /> " /> " & Cells(Rows.Count, "D").End(xlUp).Row).Value
    For I = 1 To UBound(arrPh)
        fl = False
        For J = 1 To UBound(arrW)
            If arrPh(I, 1) Like "*" & arrW(J, 1) & "*" Then
                ReDim Preserve arrTemp1(I)
                arrTemp1(I) = arrPh(I, 1)
                fl = True
                Exit For
            End If
        Next
        If Not fl Then
            N = N + 1
            ReDim Preserve arrTemp2(N)
            arrTemp2(N) = arrPh(I, 1)
        End If
    Next
    Columns("D").ClearContents
    Range("D1").Resize(UBound(arrTemp1) + 1) = Application.Transpose(arrTemp1)
    Columns("F").ClearContents
    Range("F1").Resize(UBound(arrTemp2) + 1) = Application.Transpose(arrTemp2)
End Sub
[/vba]

Автор - lybashevv
Дата добавления - 28.11.2016 в 13:47
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Доделать макрос поиска слов в фразах (Макросы/Sub)
Страница 1 из 11
Поиск:

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