Новости:

Прикрепить к сообщению можно только файлы xls, gif, jpg, rar, zip,7z, bas, frm, cls, doc размером до 150 Кб.

Главное меню

макрос копирования строки по критерию

Автор cheshiki1, 15.06.2012, 11:39

« назад - далее »

cheshiki1

Суть: в ячейку D19 вписываю 1, макрос находит в этом столбце выше 1 и копирует все остальные данные с найденной строки в ту где прописана 1. в следующей строке пишу 4 макрос находит выше 4 и та же процедура.
Заранее спс.

листов будет много и желательно чтобы макрос работал на всех.

Шпец Докапыч

В модуле листа, где требуется данная функциональность, пишем:
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Count > 1 Then Exit Sub
 If Target.Column = 4 Then
   r = Target.Row - 1
   While Cells(r, 4) <> Target Or r < 14
     r = r - 1
   Wend
   If r < 14 Then MsgBox "Нет соответствий", 16: Exit Sub
   Application.EnableEvents = 0
   Cells(Target.Row, 5).Resize(1, 16).Value = Cells(r, 5).Resize(1, 16).Value
   Application.EnableEvents = 1
 End If
End Sub
Знания недостаточно, необходимо применение. Желания недостаточно, необходимо действие. (с) Брюс Ли

cheshiki1

#2
СПС а в модуль книги как нибудь можно. Или если в модуль листа то как нибудь автоматизировать прописку макроса в модуль листа.

Шпец Докапыч

Можно. Тот же код (без изменений) кидай в Workbook_SheetChange.
Знания недостаточно, необходимо применение. Желания недостаточно, необходимо действие. (с) Брюс Ли

cheshiki1

чет не проходит, наверно из за того что там есть уже пару макросов. Посмотрите Плиз.

Шпец Докапыч

Правильный заголовок процедуры должен быть:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Знания недостаточно, необходимо применение. Желания недостаточно, необходимо действие. (с) Брюс Ли

cheshiki1

почти работает, В процесе заполнения таблицы иногда выскаивает ошибка с подсветкой данной строки
While Cells(r, 4) <> Target Or r < 14 не расскажите суть данной строки. В основном если числа нет в списке выше.

Шпец Докапыч

Не отладил как следует, - надо бы заменить: Or r < 14 на And r >= 14.
Знания недостаточно, необходимо применение. Желания недостаточно, необходимо действие. (с) Брюс Ли

cheshiki1

#8
еще нашел недочет, В столбце M формула после копирования превращается в значение., а хотелось бы формулу. В столбце L тоже может появится формула её тоже если есть нужно копировать.

Шпец Докапыч

Тогда, пожалуй, скопируем как есть (значение+формула+формат):
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  If Target.Count > 1 Then Exit Sub
  If Target.Column = 4 Then
    r = Target.Row - 1
    While Cells(r, 4) <> Target And r >= 14
      r = r - 1
    Wend
    If r < 14 Then MsgBox "Нет соответствий", 16: Exit Sub
    Application.EnableEvents = 0
    Cells(r, 5).Resize(1, 16).Copy Cells(Target.Row, 5).Resize(1, 16) 'правка
    Application.EnableEvents = 1
  End If
End Sub
Знания недостаточно, необходимо применение. Желания недостаточно, необходимо действие. (с) Брюс Ли

cheshiki1

ещё раз большое спасибо.
на этом пожалуй все.