Поиск фразы в столбце и создание записи в соседнем столбце

@blackeangel · Регистрация: 22.07.2015

Всем добрый день. Есть такая не сложная задача:
Найти столбец содержащий в первой строке слово "маршрут", в нём искать регулярные выражения как 3000,3100,3200,3300,3400,3600,3800,3801,2400 и справа от столбца с "маршрут" создать столбец "пришёл" в котором будем писать если нашлось 3000, то пишем 3000,если нет 3000, но нашлось 3100 то пишем 3100 и тд до последней записи в файле.
Как это все реализовать?Помогите пожалуйста!

@Казанский · 11.12.2015, 15:14

blackeangel, искать по совпадению, т.е. ячейка должна содержать число 3000 или 3100, или по вхождению, например "цена билета 3200р"?
Лучше файл-пример приложите.

@blackeangel · 11.12.2015, 15:25 **[ТС]**

Вот пример во вложении как должно получиться.
Думал взять из поиск и удаление строки по шаблону,но не сообразил как при крутить столько условий

@blackeangel · 11.12.2015, 23:13 **[ТС]**

Казанский, Вот пример до и после как должно получиться, чтоб понятнее было...и искать по вхождению. .

@blackeangel · 13.12.2015, 16:37 **[ТС]**

Казанский, часть можно взять отсюда
Определение первого слова в ячейке Excel
А другую часть отсюда
http://macros-vba.ru/makrosy/e... ov-v-excel
И как то их соединить...

Добавлено через 43 минуты
себе представляю это так:

Visual Basic

sub типа пример ()
задаем переменные
а=3000
b=3100
c=3200
d=3300
...
ищем столбец содержащий в первой строке "Маршрут"
Получаем его номер
дальше запускаем for со 2 до последней строки содержащей запись в столбце с "Маршрут"
запускаем if содержит(входит) а then
в столбец с номером "Маршрут" +1 и строка [i] пишем константу а
else
 if содержит(входит) b then
в столбец с номером "Маршрут" +1 и строка [i] пишем константу b
 else
     if содержит(входит) c then
в столбец с номером "Маршрут" +1 и строка [i] пишем константу c
     else
... 
end if
end sub

но как это реализовать на ЯП не знаю...

@blackeangel · 14.12.2015, 07:22 **[ТС]**

Вот ещё один пример,если он поможет.Как было и как должно быть на разных листах

@eritik · 14.12.2015, 11:28

пока для начала вот так...

Visual Basic

Sub Find01()
Application.ScreenUpdating = False
sWhatFind = "Маршрут"
Cells.Find(What:=sWhatFind, After:=ActiveCell, SearchOrder:=xlByColumns).Activate
ncolumn = ActiveCell.Column ' определяем столбец ячейки
MsgBox ("Номер столбца Маршрут" & ncolumn)
i = 2
Do While Cells(i, ncolumn).Value <> Empty
'Cells(i, ncolumn + 1).Value =условия подстановки
i = i + 1
Loop
Application.ScreenUpdating = True
End Sub

@blackeangel · 14.12.2015, 14:44 **[ТС]**

eritik,

Visual Basic

Sub raspil()
Dim A As String, B As String, C As String, D As String, E As String, F As String, G As String, H As String
Application.ScreenUpdating = False
A = "3200"
B = "3000"
C = "3100"
D = "3400"
E = "3300"
F = "3800"
G = "3801"
H = "2400"
sWhatFind = "Маршрут"
Cells.Find(What:=sWhatFind, After:=ActiveCell, SearchOrder:=xlByColumns).Activate
ncolumn = ActiveCell.Column ' определяем столбец ячейки
MsgBox ("Номер столбца Маршрут" & ncolumn)
i = 2
Do While Cells(i, ncolumn).Value <> Empty
 
If Cell Like A Then
    Cells(i, ncolumn + 1).Value = A
    Else
        If Cell Like B Then
        Cells(i, ncolumn + 1).Value = B
    Else
        If Cell Like C Then
        Cells(i, ncolumn + 1).Value = C
            Else
        If Cell Like D Then
        Cells(i, ncolumn + 1).Value = D
            Else
        If Cell Like E Then
        Cells(i, ncolumn + 1).Value = E
            Else
        If Cell Like F Then
        Cells(i, ncolumn + 1).Value = F
            Else
        If Cell Like G Then
        Cells(i, ncolumn + 1).Value = G
            Else
        If Cell Like H Then
        Cells(i, ncolumn + 1).Value = H
 
    End If
    End If
        End If
        End If
        End If
        End If
        End If
End If
i = i + 1
Loop
Application.ScreenUpdating = True
End Sub

Не заработало...

Добавлено через 23 минуты
А вот отсюда что можно стырить?:

Visual Basic

Sub Udalenie_Strok_Po_Shablonu()
    Dim r As Long, FirstRow As Long, LastRow As Long
    Dim Region As Range, iRow As Range, Cell As Range
    Dim Shablon As String
 
    Shablon = "здесь вводится искомый текст"
 
    Set Region = ActiveSheet.UsedRange
    FirstRow = Region.Row
    LastRow = Region.Row - 1 + Region.Rows.Count 
        For r = LastRow To FirstRow Step -1
        Set iRow = Region.Rows(r - FirstRow + 1)
            For Each Cell In iRow.Cells
                If Cell Like Shablon Then
                    Rows(r).Delete
                End If
            Next Cell
        Next r
End Sub

@eritik · 14.12.2015, 15:14

Visual Basic

Sub Find01()
Dim A1 As String, B As String, C As String, D As String, E As String, F As String, G As String, H As String
Application.ScreenUpdating = False
i = 2
sWhatFind = "Ìàðøðóò"
Cells.Find(What:=sWhatFind, After:=ActiveCell, SearchOrder:=xlByColumns).Activate
ncolumn = ActiveCell.Column ' îïðåäåëÿåì ñòîëáåö ÿ÷åéêè
MsgBox ("Íîìåð ñòîëáöà Ìàðøðóò" & ncolumn)
A = Cells(i, ncolumn).Value
Do While Cells(i, ncolumn).Value <> Empty
'Cells(i, ncolumn + 1).Value = åñëè((Find("3000", Cells(i, ncolumn), 1) > 0) = 2, "3000", "")
If Cells(i, ncolumn).Value Like "*3000*" Then
    Cells(i, ncolumn + 1).Value = "3000"
    Else
        If Cells(i, ncolumn).Value Like "*3100*" Then
        Cells(i, ncolumn + 1).Value = "3100"
    Else
        If Cells(i, ncolumn).Value Like "*3200*" Then
        Cells(i, ncolumn + 1).Value = "3200"
            Else
        If Cells(i, ncolumn).Value Like "*3300*" Then
        Cells(i, ncolumn + 1).Value = "3300"
            Else
        If Cells(i, ncolumn).Value Like "*3400*" Then
        Cells(i, ncolumn + 1).Value = "3400"
        Else
         If Cells(i, ncolumn).Value Like "*3600*" Then
        Cells(i, ncolumn + 1).Value = "3600"
            Else
        If Cells(i, ncolumn).Value Like "*3800*" Then
        Cells(i, ncolumn + 1).Value = "3800"
            Else
        If Cells(i, ncolumn).Value Like "*3801*" Then
        Cells(i, ncolumn + 1).Value = "3801"
            Else
        If Cells(i, ncolumn).Value Like "*2400*" Then
        Cells(i, ncolumn + 1).Value = "2400"
 End If
    End If
    End If
        End If
        End If
        End If
        End If
        End If
End If
i = i + 1
Loop
Application.ScreenUpdating = True
End Sub

Добавлено через 15 минут
..забыл мусор поудалять ))

@blackeangel · 14.12.2015, 15:33 **[ТС]**

eritik, тогда Dim можно закоментить.
И ещё что за кракозябры?

Добавлено через 5 минут
eritik,И почему от констант ушёл?

@eritik · 14.12.2015, 15:52

кузебряки - это русский текст; пока перемещал между удаленными ПК -потерял исходное форматирование(
мне было проще без констант.
DIM и A = Cells(i, ncolumn).Value можно так же закоментить или удалить.

@blackeangel · 15.12.2015, 07:35 **[ТС]**

eritik,

Visual Basic

Sub raspil()
Application.ScreenUpdating = False
i = 2
sWhatFind = "Маршрут"
Cells.Find(What:=sWhatFind, After:=ActiveCell, SearchOrder:=xlByColumns).Activate
ncolumn = ActiveCell.Column
Do While Cells(i, ncolumn).Value <> Empty
If Cells(i, ncolumn).Value Like "*3000*" Then
Cells(i, ncolumn + 1).Value = "3000"
Else
If Cells(i, ncolumn).Value Like "*3100*" Then
Cells(i, ncolumn + 1).Value = "3100"
Else
If Cells(i, ncolumn).Value Like "*3200*" Then
Cells(i, ncolumn + 1).Value = "3200"
Else
If Cells(i, ncolumn).Value Like "*3300*" Then
Cells(i, ncolumn + 1).Value = "3300"
Else
If Cells(i, ncolumn).Value Like "*3400*" Then
Cells(i, ncolumn + 1).Value = "3400"
Else
If Cells(i, ncolumn).Value Like "*3600*" Then
Cells(i, ncolumn + 1).Value = "3600"
Else
If Cells(i, ncolumn).Value Like "*3800*" Then
Cells(i, ncolumn + 1).Value = "3800"
Else
If Cells(i, ncolumn).Value Like "*3801*" Then
Cells(i, ncolumn + 1).Value = "3801"
Else
If Cells(i, ncolumn).Value Like "*2400*" Then
Cells(i, ncolumn + 1).Value = "2400"
End If
End If
End If
End If
End If
End If
End If
End If
End If
i = i + 1
Loop
Application.ScreenUpdating = True
End Sub

Ругается на ошибку
Can't execute code in break mode

@eritik · 15.12.2015, 07:55

все отлично работает.
оставнови выполнение макроса "reset" и запусти заново.

@blackeangel · 15.12.2015, 08:14 **[ТС]**

eritik, прошу прощения за накат,надо было Эксель перезапустить)))

@Казанский · 15.12.2015, 15:51

blackeangel, eritik, ну вы даете

Про массивы, циклы слышали?

Visual Basic

Sub raspil()
Application.ScreenUpdating = False
i = 2
Dim v$(): v = Split("3000,3100,3200,3300,3400,3600,3800,3801,2400", ",")
sWhatFind = "Маршрут"
Cells.Find(What:=sWhatFind, After:=ActiveCell, SearchOrder:=xlByColumns).Activate
ncolumn = ActiveCell.Column
Do While Cells(i, ncolumn).Value <> Empty
  s = Cells(i, ncolumn).Text
  For Each x In v
    If InStr(s, x) Then
      Cells(i, ncolumn + 1).Value = x
      Exit For
    End If
  Next
  i = i + 1
Loop
Application.ScreenUpdating = True
End Sub

Добавлено через 33 минуты
blackeangel, так в соотв. с ТЗ - вставка столбца, т.е. данные справа от ст. Маршрут не будут затерты.
Заголовок не обязан быть в первой строке.

Visual Basic

Sub blackeangel()
 
Const HDR1 = "Маршрут"
Const HDR2 = "Пришёл"
Const SPIS = "3000,3100,3200,3300,3400,3600,3800,3801,2400" 'список ЧИСЕЛ через запятую
  'если нужно включить в список нечисловое значение, его надо заключить в ДВОЙНЫЕ кавычки,
  'например "3000,3100,""3900a"",2500"
 
Dim x As Range
Set x = Cells.Find(What:=HDR1, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
If x Is Nothing Then
  MsgBox "Заголовок '" & HDR1 & "' не найден", vbExclamation
  Exit Sub
End If
Columns(x.Column + 1).Insert
x.Offset(, 1) = HDR2
With Range(x.Offset(1), Cells(Rows.Count, x.Column).End(xlUp)).Offset(, 1)
  .FormulaR1C1 = "=INDEX({" & SPIS & "},MATCH(1,SEARCH(""*""&{" & SPIS & "}&""*"",RC[-1]),))"
  .Value = .Value
End With
End Sub

@blackeangel · 15.12.2015, 15:58 **[ТС]**

Казанский, это хорошо когда числиное значение надо подставить,а когда надо согласовать 2 массива?потому что цифры согласуются с словами. То ьишь согласно твоему коду надо брать ещё один массив и как то его согласовывать с этим.Т.к. 3100 это ЭМЦ к примеру. В этом коде на подстановку я заменил на буквы,а поиск выполняется по цифрам.Одним массивом сия невозможно.

Добавлено через 5 минут
У меня сделано так и все работает

Visual Basic

Sub raspil()
Application.ScreenUpdating = False
i = 2
sWhatFind = "Маршрут"
Cells.Find(What:=sWhatFind, After:=ActiveCell, SearchOrder:=xlByColumns).Activate
ncolumn = ActiveCell.Column
    Columns(ncolumn + 1).Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(1, ncolumn + 1).Value = "ЦЕХ"
Do While Cells(i, ncolumn).Value <> Empty
If Cells(i, ncolumn).Value Like "*3200*" Then
Cells(i, ncolumn + 1).Value = "ЦВО"
Else
If Cells(i, ncolumn).Value Like "*3000*" Then
Cells(i, ncolumn + 1).Value = "ЭМЦ"
Else
If Cells(i, ncolumn).Value Like "*3600*" Then
Cells(i, ncolumn + 1).Value = "ПММ"
Else
If Cells(i, ncolumn).Value Like "*3100*" Then
Cells(i, ncolumn + 1).Value = "СМЦ"
Else
If Cells(i, ncolumn).Value Like "*3400*" Then
Cells(i, ncolumn + 1).Value = "МЦ"
Else
If Cells(i, ncolumn).Value Like "*3300*" Then
Cells(i, ncolumn + 1).Value = "ЦКМ"
Else
If Cells(i, ncolumn).Value Like "*3800*" Then
Cells(i, ncolumn + 1).Value = "ОВК"
Else
If Cells(i, ncolumn).Value Like "*3801*" Then
Cells(i, ncolumn + 1).Value = "ОВК"
Else
If Cells(i, ncolumn).Value Like "*2400*" Then
Cells(i, ncolumn + 1).Value = "БИХ"
End If
End If
End If
End If
End If
End If
End If
End If
End If
i = i + 1
Loop
Application.ScreenUpdating = True
End Sub

Согласно ТЗ и вставляет столбец и имя ему задаёт и тд

@Казанский · 15.12.2015, 16:00

blackeangel, то есть ищем одно, а в столбец записываем другое (соответствующее)? Это можно и с одним массивом, но удобнее и логичнее с двумя отдельными. И с циклом, и с формулой - там в формуле первый SPIS - что записывать, второй SPIS - что искать.

@blackeangel · 15.12.2015, 16:23 **[ТС]**

Казанский, для меня это сложно уже.Особенно если учесть что последний раз что то прогил 6 лет назад и то на паскале)))
А для интересного и сложного есть мною созданная тема
Сложная задача по поиску и вхождению
А в формуле так и не понял где там те значения что вставляются,и как 2масива завязать...

Добавлено через 16 минут
Или вот ещё тема интересная для вас
Поиск процесса через vba

@Казанский · 15.12.2015, 16:26

blackeangel,

Visual Basic

Sub blackeangel()
 
Const HDR1 = "Маршрут"
Const HDR2 = "ЦЕХ"
Const SPIS = "3200,3000,3600,3100,3400,3300,3800,3801,2400" 'список искомых через запятую
Const TSEH = "ЦВО,ЭМЦ,ПММ,СМЦ,МЦ,ЦКМ,ОВК,ОВК,БИХ" 'список подставляемых через запятую
 
Dim x As Range
Set x = Cells.Find(What:=HDR1, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
If x Is Nothing Then
  MsgBox "Заголовок '" & HDR1 & "' не найден", vbExclamation
  Exit Sub
End If
Columns(x.Column + 1).Insert
x.Offset(, 1) = HDR2
With Range(x.Offset(1), Cells(Rows.Count, x.Column).End(xlUp)).Offset(, 1)
  .FormulaR1C1 = "=INDEX({""" & Replace(TSEH, ",", """,""") & """},MATCH(1,SEARCH(""*""&{""" & Replace(SPIS, ",", """,""") & """}&""*"",RC[-1]),))"
  .Value = .Value 'закомментируйте, чтобы оставить на листе формулы
End With
End Sub

@eritik · 15.12.2015, 19:08

Сообщение от Казанский

eritik, ну вы даете Про массивы, циклы слышали?

кто это? что это?

я за vba сел пару месяцев назад ((...по необходимости..пока вот вникаю. разбираюсь и учусь вот на таких задачках.
массивы пока "темный лес"

спасибо за подсказку по упрощению.

@Казанский 15131 / 6405 / 1730 Регистрация: 24.09.2011 Сообщений: 9,999
	15.12.2015, 16:00	17
	blackeangel, то есть ищем одно, а в столбец записываем другое (соответствующее)? Это можно и с одним массивом, но удобнее и логичнее с двумя отдельными. И с циклом, и с формулой - там в формуле первый SPIS - что записывать, второй SPIS - что искать. 0

@blackeangel 16 / 7 / 1 Регистрация: 22.07.2015 Сообщений: 759
	15.12.2015, 16:23 [ТС]	18
	Казанский, для меня это сложно уже.Особенно если учесть что последний раз что то прогил 6 лет назад и то на паскале))) А для интересного и сложного есть мною созданная тема Сложная задача по поиску и вхождению А в формуле так и не понял где там те значения что вставляются,и как 2масива завязать... Добавлено через 16 минут Или вот ещё тема интересная для вас Поиск процесса через vba 0

Поиск фразы в столбце и создание записи в соседнем столбце

Решение

Решение

@Казанский 15131 / 6405 / 1730 Регистрация: 24.09.2011 Сообщений: 9,999
	11.12.2015, 15:14	2
	blackeangel, искать по совпадению, т.е. ячейка должна содержать число 3000 или 3100, или по вхождению, например "цена билета 3200р"? Лучше файл-пример приложите. 0

@blackeangel 16 / 7 / 1 Регистрация: 22.07.2015 Сообщений: 759
	14.12.2015, 15:33 [ТС]	10
	eritik, тогда Dim можно закоментить. И ещё что за кракозябры? Добавлено через 5 минут eritik,И почему от констант ушёл? 0

@eritik 18 / 19 / 5 Регистрация: 14.09.2015 Сообщений: 104
	14.12.2015, 15:52	11
	кузебряки - это русский текст; пока перемещал между удаленными ПК -потерял исходное форматирование( мне было проще без констант. DIM и A = Cells(i, ncolumn).Value можно так же закоментить или удалить. 0

@eritik 18 / 19 / 5 Регистрация: 14.09.2015 Сообщений: 104
	15.12.2015, 07:55	13
	все отлично работает. оставнови выполнение макроса "reset" и запусти заново. 1

@blackeangel 16 / 7 / 1 Регистрация: 22.07.2015 Сообщений: 759
	15.12.2015, 08:14 [ТС]	14
	eritik, прошу прощения за накат,надо было Эксель перезапустить))) 0

@eritik 18 / 19 / 5 Регистрация: 14.09.2015 Сообщений: 104
	15.12.2015, 19:08	20
	Сообщение от Казанский eritik, ну вы даете Про массивы, циклы слышали? кто это? что это? я за vba сел пару месяцев назад ((...по необходимости..пока вот вникаю. разбираюсь и учусь вот на таких задачках. массивы пока "темный лес" спасибо за подсказку по упрощению. 0