Перенос ячеек с определенным условием

[foxter1989]

Здравствуйте.
Прошу помощи, так как голова, почему то сегодня отказывается варить совершенно.
Собственно загвоздка в том, что не могу сделать копирование ячеек с определенным текстом. Текст в таких ячейках может начинаться с договор №, контракт № или без договора.
Собственно во вложении такой файлик, только ОЧЕНЬ укороченный (порядка на 40000 строк)
В первом листе - выгрузка из 1С. Во втором - как оно должно быть.
Т.е.
Если в ячейке присутствует слово, оговоренное условием, то копируется в соседнюю ячейку. Если среди них попадается со словом "Без договора", то заливается. Хотя без последнего можно обойтись. Сделать условное форматирование - не проблема. А вот написать макрос мне, как начинающему чайнику, проблематично.
По теме читал и много, но вот почему то безрезультатно.
Помогите, пожалуйста.

[foxter1989]

Собственно по последнему пункту уже написано:

Set mass = Range([B2], Range("B" & Rows.Count).End(xlUp))  
    Application.ScreenUpdating = False
    mass.Font.Color = 0: mass.Font.Bold = 0 

    For Each cell In mass.Cells 
        pos = 1
        If cell.Text Like "*" & txt & "*" Then
            arr = Split(cell.Text, txt, , vbTextCompare) 
            If UBound(arr) > 0 Then   
                For Each v In arr   
                    pos = pos + Len(v) 
                    With cell.Characters(pos, Len(txt))
                        .Font.ColorIndex = 3    
                        .Font.Bold = True  
                    End With
                    pos = pos + Len(txt)
                Next v
            End If
        End If
    Next cell

[foxter1989]

Перечитал что написал утром. Волосы встали дыбом.
Перефразирую:
Мне нужно что бы выполнялся определенной колонке поиск ячейки с текстом Договор или Контракт и совершить перенос этой ячейки в ячейку справа.
Я просто не знаю как осуществить поиск...

[Hugo121]

Записываете рекордером этот поиск и получаете код.
Но можно и просто циклом пройтись по диапазону. Впрочем это ведь уже написано?

[foxter1989]

Собственно я не силен в написании нового кода, но могу адаптировать чужой.
Фактически тот, что выше я даже объяснить могу, только не знаю как добавить к нему копирование найденной ячейки в соседнюю справа.

[Hugo121]

Соседняя справа - это будет источник.offset(0,1)
Копирование тоже записываете рекордером.
Если нужно скопировать только значение - то
куда.value=откуда.value

[foxter1989]

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

Set mass = Range([B2], Range("B" & Rows.Count).End(xlUp))  
    Application.ScreenUpdating = False
    mass.Font.Color = 0: mass.Font.Bold = 0 

    For Each cell In mass.Cells 
        pos = 1
        If cell.Text Like "*" & txt & "*" Then
            arr = Split(cell.Text, txt, , vbTextCompare) 
            If UBound(arr) > 0 Then   
                For Each v In arr   
                    pos = pos + Len(v) 
                    With cell.Characters(pos, Len(txt))
                    cell.Offset(pos - 1, pos).Value = cell(pos, pos).Value
                        .Font.ColorIndex = 3    
                        .Font.Bold = True  
                    End With
                    pos = pos + Len(txt)
                Next v
            End If
        End If
    Next cell

Благодарю за наставления

[foxter1989]

Гм. Новый трабл )
Подскажите, пожалуйста, команду добавления новых ячеек со сдвигом вправо.
Через запись в коде показывает

    Columns("D:D").Select
    Range("D2").Activate
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

но при воспроизведении макроса он добавляет столько столбцов, сколько занимает по ширине сама таблица +2 ячейки.
Что же тут не так? Подскажите, пожалуйста

[27102014]

Попробуйте так

Columns("D:D").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

У Вас в таблице объединенная ячейка, нужно без метода Select

[foxter1989]

Идеально! Благодарю!