Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 13.04.2015, 09:44   #1
foxter1989
Пользователь
 
Регистрация: 13.04.2015
Сообщений: 15
По умолчанию Перенос ячеек с определенным условием

Здравствуйте.
Прошу помощи, так как голова, почему то сегодня отказывается варить совершенно.
Собственно загвоздка в том, что не могу сделать копирование ячеек с определенным текстом. Текст в таких ячейках может начинаться с договор №, контракт № или без договора.
Собственно во вложении такой файлик, только ОЧЕНЬ укороченный (порядка на 40000 строк)
В первом листе - выгрузка из 1С. Во втором - как оно должно быть.
Т.е.
Если в ячейке присутствует слово, оговоренное условием, то копируется в соседнюю ячейку. Если среди них попадается со словом "Без договора", то заливается. Хотя без последнего можно обойтись. Сделать условное форматирование - не проблема. А вот написать макрос мне, как начинающему чайнику, проблематично.
По теме читал и много, но вот почему то безрезультатно.
Помогите, пожалуйста.
Вложения
Тип файла: zip пример.zip (13.8 Кб, 18 просмотров)
foxter1989 вне форума Ответить с цитированием
Старый 13.04.2015, 12:40   #2
foxter1989
Пользователь
 
Регистрация: 13.04.2015
Сообщений: 15
По умолчанию

Собственно по последнему пункту уже написано:
Код:
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 вне форума Ответить с цитированием
Старый 13.04.2015, 13:14   #3
foxter1989
Пользователь
 
Регистрация: 13.04.2015
Сообщений: 15
По умолчанию

Перечитал что написал утром. Волосы встали дыбом.
Перефразирую:
Мне нужно что бы выполнялся определенной колонке поиск ячейки с текстом Договор или Контракт и совершить перенос этой ячейки в ячейку справа.
Я просто не знаю как осуществить поиск...
foxter1989 вне форума Ответить с цитированием
Старый 13.04.2015, 13:30   #4
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,166
По умолчанию

Записываете рекордером этот поиск и получаете код.
Но можно и просто циклом пройтись по диапазону. Впрочем это ведь уже написано?
webmoney: E265281470651 Z422237915069 R418926282008
Hugo121 вне форума Ответить с цитированием
Старый 13.04.2015, 13:34   #5
foxter1989
Пользователь
 
Регистрация: 13.04.2015
Сообщений: 15
По умолчанию

Собственно я не силен в написании нового кода, но могу адаптировать чужой.
Фактически тот, что выше я даже объяснить могу, только не знаю как добавить к нему копирование найденной ячейки в соседнюю справа.
foxter1989 вне форума Ответить с цитированием
Старый 13.04.2015, 14:47   #6
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,166
По умолчанию

Соседняя справа - это будет источник.offset(0,1)
Копирование тоже записываете рекордером.
Если нужно скопировать только значение - то
куда.value=откуда.value
webmoney: E265281470651 Z422237915069 R418926282008
Hugo121 вне форума Ответить с цитированием
Старый 13.04.2015, 15:31   #7
foxter1989
Пользователь
 
Регистрация: 13.04.2015
Сообщений: 15
По умолчанию

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

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 вне форума Ответить с цитированием
Старый 14.04.2015, 08:41   #8
foxter1989
Пользователь
 
Регистрация: 13.04.2015
Сообщений: 15
По умолчанию

Гм. Новый трабл )
Подскажите, пожалуйста, команду добавления новых ячеек со сдвигом вправо.
Через запись в коде показывает
Код:
    Columns("D:D").Select
    Range("D2").Activate
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
но при воспроизведении макроса он добавляет столько столбцов, сколько занимает по ширине сама таблица +2 ячейки.
Что же тут не так? Подскажите, пожалуйста
foxter1989 вне форума Ответить с цитированием
Старый 14.04.2015, 08:59   #9
27102014
Форумчанин
 
Регистрация: 27.10.2014
Сообщений: 248
По умолчанию

Попробуйте так
Код:
Columns("D:D").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
У Вас в таблице объединенная ячейка, нужно без метода Select
27102014 вне форума Ответить с цитированием
Старый 14.04.2015, 09:01   #10
foxter1989
Пользователь
 
Регистрация: 13.04.2015
Сообщений: 15
По умолчанию

Идеально! Благодарю!
foxter1989 вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Копирование строк с разных листов в один с определенным условием Lancelot-r Microsoft Office Excel 4 07.11.2012 00:59
Перенос данных с определенным цветом на новый лист xinortavon Microsoft Office Excel 4 24.09.2012 09:35
Заливка с определенным условием layriona Microsoft Office Excel 1 16.05.2012 13:50
Макрос для копирования значений из нескольких файлов в один общий с определенным условием копирования zenner Microsoft Office Excel 0 21.03.2011 14:48
Помогите сцепить ячейки с определенным условием 7erge Microsoft Office Excel 4 23.07.2008 09:47