Макрос производит поиск и ряд действий с искомым, если иском

Дата: Среда, 08.07.2015, 09:16 | Сообщение № 1

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

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

Сообщений: 10

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

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

Excel 2010

Здравствуйте Уважаемые Форумчане!
Подскажите пожалуйста, нужно чтобы макрос производил поиск на листе InsertTMP и при нахождении искомого (Name A: ) производил ряд действий (удалял Name A: , а оставшийся текст в этой ячейки Text A копировал и вставлял его в соответствующее поле WMA на листе RU), если искомое отсутствовало (Name B: ), то пропускал ряд действий связанных с ним (удалить Name B: , оставшийся текст в этой ячейки Text B копировать и вставить его в соответствующее поле WMB на листе RU) и переходил к следующему (Name C: ) и т.д.
[vba]

Код

Sub Macros()

     Sheets("InsertTMP").Select

     Cells.Find(What:="Name A:", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
         :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
         False, SearchFormat:=False).Activate
     ActiveCell.Select
         Cells.Replace What:="Name A: ", Replacement:="", LookAt:=xlPart, _
         SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
         ReplaceFormat:=False
     Selection.Copy
     Sheets("RU").Select
     Range("WMA").Select
     Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
         SkipBlanks:=False, Transpose:=False
     Sheets("InsertTMP").Select

     Cells.Find(What:="Name B:", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
         :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
         False, SearchFormat:=False).Activate
     ActiveCell.Select
     Cells.Replace What:="Name B: ", Replacement:="", LookAt:=xlPart, _
         SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
         ReplaceFormat:=False
     Selection.Copy
     Sheets("RU").Select
     Range("WMB").Select
     Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
         SkipBlanks:=False, Transpose:=False
     Sheets("InsertTMP").Select

     Cells.Find(What:="Name C:", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
         :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
         False, SearchFormat:=False).Activate
     ActiveCell.Select
         Cells.Replace What:="Name C: ", Replacement:="", LookAt:=xlPart, _
         SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
         ReplaceFormat:=False
     Selection.Copy
     Sheets("RU").Select
     Range("WMC").Select
     Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
         SkipBlanks:=False, Transpose:=False
     Sheets("InsertTMP").Select

End Sub

[/vba]
PS: Пример прикреплен.
Заранее Благодарю Вас.

Код

[/vba]
PS: Пример прикреплен.
Заранее Благодарю Вас.pirat_m

К сообщению приложен файл: 8077759.xls (31.5 Kb)

СообщениеЗдравствуйте Уважаемые Форумчане!
Подскажите пожалуйста, нужно чтобы макрос производил поиск на листе InsertTMP и при нахождении искомого (Name A: ) производил ряд действий (удалял Name A: , а оставшийся текст в этой ячейки Text A копировал и вставлял его в соответствующее поле WMA на листе RU), если искомое отсутствовало (Name B: ), то пропускал ряд действий связанных с ним (удалить Name B: , оставшийся текст в этой ячейки Text B копировать и вставить его в соответствующее поле WMB на листе RU) и переходил к следующему (Name C: ) и т.д.
[vba]

Код

[/vba]
PS: Пример прикреплен.
Заранее Благодарю Вас.

Автор - pirat_m
Дата добавления - 08.07.2015 в 09:16

Дата: Среда, 08.07.2015, 10:42 | Сообщение № 2

Группа: Модераторы

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

Сообщений: 2198

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

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

Excel 2010, 2016

pirat_m, здравствуйте, можно так, например:[vba]

Код

Sub Macros()
     Dim shTemp As Worksheet, shRu As Worksheet
     Dim temp As String, wm As String
     Set shTemp = Sheets("InsertTMP")
     Set shRu = Sheets("RU")
     shTemp.Activate
     For i = 2 To shRu.Cells(shRu.Rows.Count, 1).End(xlUp).Row
         temp = shRu.Cells(i, 1)
         On Error Resume Next
             wm = Replace(Cells.Find(What:=temp, LookAt:=xlPart).Value, temp, "")
             If Err = 0 Then
                 shRu.Cells(i, 2) = Trim(wm)
                 adr = Cells.Find(What:=temp, LookAt:=xlPart).Address
                 Range(adr) = Trim(wm)
             End If
         On Error GoTo 0
     Next i
     shRu.Activate
End Sub

[/vba]

К сообщению приложен файл: 8077759-1.xls (34.5 Kb)

ЯД: 410013299366744 WM: R193491431804

Дата: Среда, 08.07.2015, 14:36 | Сообщение № 3

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

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

Сообщений: 10

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

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

Excel 2010

Здравствуйте, Manyasha
Спасибо за ваш вариант, но можно его еще чуточку подправить: нужно чтобы "Name A: " удалялся вместе с пробелом и результат вставлялся в указанный диапазон (например в WR), потому что у меня таких форм в книге Excel 6 шт.
Прикрепил новый файл к этому сообщению.

К сообщению приложен файл: 0776914.xls (34.0 Kb)

Дата: Среда, 08.07.2015, 15:03 | Сообщение № 4

Группа: Модераторы

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

Сообщений: 2198

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

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

Excel 2010, 2016

pirat_m, в начало макроса добавьте[vba]

Код

rngName = InputBox("Введите название диапазона:", , "WR")

[/vba]
а первую строчку цикла замените на:[vba]

Код

    rFirst = Range(rngName).Row
      rLast = Range(rngName).Rows.Count + Range(rngName).Row - 1
      For i = rFirst To rLast

[/vba]

ЯД: 410013299366744 WM: R193491431804

Дата: Среда, 08.07.2015, 16:03 | Сообщение № 5

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

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

Сообщений: 10

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

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

Excel 2010

Manyasha, макрос работает замечательно Большое Вам Спасибо hands

Могли бы Вы еще подсказать, что нужно еще добавить, чтобы в получаемом результате не было пробелом в начале ячейки?

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

Группа: Модераторы

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

Сообщений: 2198

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

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

Excel 2010, 2016

pirat_m, Его там и так нет. Функция Trim убивает пробелы.
Если не нравится, можно temp так переназначить:[vba]

Код

temp = shRu.Cells(i, 1) & " "

[/vba]

ЯД: 410013299366744 WM: R193491431804

Дата: Среда, 08.07.2015, 16:29 | Сообщение № 7

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

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

Сообщений: 10

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

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

Excel 2010

Manyasha, к сожалению с этой добавкой макрос перестает работать

Я только неделю работаю с макросами в Excel, поэтому мало что знаю, не судите строго.

Дата: Среда, 08.07.2015, 16:40 | Сообщение № 8

Группа: Модераторы

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

Сообщений: 2198

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

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

Excel 2010, 2016

pirat_m, у меня все работает:[vba]

Код

For i = rFirst To rLast
temp = shRu.Cells(i, 1) & " "
On Error Resume Next

[/vba]Проверьте, так ли у Вас.

Да не обязательно этот пробел прибавлять к строке, я же писала

Цитата Manyasha, 08.07.2015 в 16:08, в сообщении № 6

Его там и так нет. Функция Trim убивает пробелы.

не верите?)

Если ошибаюсь, показывайте в файле, что не работает, где пробелы остаются и т.д.

ЯД: 410013299366744 WM: R193491431804

Дата: Среда, 08.07.2015, 17:24 | Сообщение № 9

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

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

Сообщений: 10

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

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

Excel 2010

Manyasha, немного разобрался и нашел в чем возникает проблема, макрос работает отлично даже без добавки ( & " ") в temp, если текст для последующей обработки макросом вставлен из блокнота, а если текст вставлен из другого источника, то остаются пробелы в начале ячейки, не помогает даже код вставки
[vba]

Код

ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:= _
False, NoHTMLFormatting:=True

[/vba]
Может тогда нужно, после вставки результата в указанный диапазон, обработать сам диапазон как-нибудь?