Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Удаление строки по цвету заливки со смещением, макрос
 
#1
10.01.2013 20:24:12
Доброго времени суток, господа.
Прошу помочь вот с такой задачкой. Есть нехитрая таблица, некоторые строки которой окрашены в определенный цвет (допустим что в красный). Эти строки означают какие-то событие. Если событие имеет подробности, то на следующей строке будут коментарии к нему, но уже не на красном фоне, а на белом. Задача заключается в удалении событий, которые не имеют подробностей. Таблица приблизительно такая:
Событие Номер1
Событие Номер2
Событие Номер3
Ололо, какой-то текст  :)  
Событие Номер4
Я использовал красный цвет текста, но в моей таблице цвет имеет не текст, а ячейка (конечно, текст тоже имеет цвет, но он нам не важен  :)  )

Результат должен выглядить так:
СобытиеНомер3
Ололо, какой-то текст  :)  
Одной из существенных проблем является то, что ячейки в разнобой объединены (по этому фильтры применять не могу) Основная привязка только к строке и к цвету ячеек в данной строке.

Алгоритм я вижу такой, что надо каждую строку сравнивать на наличиие окрашеных ячеек со следующей. Если цвет первой и второй строк красный, то первую надо удалить. Если цвет двух соседних строк разный, то оставить как есть. При этом проверяться должно не попарно, типа 1 и 2, а потом 3 и 4, а 1 и 2, 2 и 3, 3 и 4.
В общем из-за отсутствий знаний синтаксиса VBA (что в будущем постараюсь исправить) прошу помощи в реализации данного макроса.
 
 
 
#2
10.01.2013 20:32:28
ну и как вам реализовать макрос?
файла нет
а переделать под свой файл вы не сможете
да и с "вразнобой объединенными" непонятки - где, как, зачем...
фрилансер Excel, VBA - контакты в профиле
"Совершенствоваться не обязательно. Выживание — дело добровольное." Э.Деминг
 
 
 
#3
10.01.2013 20:53:24
ikki, Вот файл

Реализовать вот так:
Цикл с первой по последнюю строку. Сравнивается наличие хоть одной красной ячейки в строке. Если имеем две строки, ячейки в которых красные, то верхнюю удалить, нижнюю оставить для сравнения со следующей.
Изменено: Derian Fox - 10.01.2013 20:56:34
 
 
 
#4
10.01.2013 20:59:54
и зачем мне ходить на гугл-докс?
или вы там и работаете?
и у вас там работают макросы?
фрилансер Excel, VBA - контакты в профиле
"Совершенствоваться не обязательно. Выживание — дело добровольное." Э.Деминг
 
 
 
#5
10.01.2013 21:15:11
Гугл докс - шаровый хостинг. По этому туда и выложил.
Файл-сохранить как - эксель. Открываете у себе и все работает.
 
 
 
#6
10.01.2013 21:24:06
Код
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub t()
  Dim f As Boolean, c As Range, r As Range
  For Each c In Intersect([b:b], ActiveSheet.UsedRange).Cells
    If c.Interior.ColorIndex = 3 Then
      If f Then
        If r Is Nothing Then Set r = c Else Set r = Union(r, c)
      End If
      f = True
    Else
      f = False
    End If
  Next
  If Not r Is Nothing Then r.EntireRow.Delete
End Sub   
фрилансер Excel, VBA - контакты в профиле
"Совершенствоваться не обязательно. Выживание — дело добровольное." Э.Деминг
 
 
 
#7
10.01.2013 21:37:40
Шикарно. Работает отлично. Огромное спасибо  :)
 
 
 
#8
11.01.2013 14:26:19
В процессе работы данного макроса нашел недостаток: При сравнении первой и второй строки удаляется вторая строка. А надо, чтобы удалялась первая.
И ещё одно условие хотел бы добавить: если последняя строка красная, то ее удалить.
 
 
 
#9
12.01.2013 19:16:34
тогда так
Код
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Function mu(r1 As Range, r2 As Range) As Range
  If r1 Is Nothing Then Set mu = r2: Exit Function
  If r2 Is Nothing Then Set mu = r1: Exit Function
  Set mu = Union(r1, r2)
End Function
 
Sub tt()
  Dim lr&, i&, c As Range, r As Range
  lr = Cells(Rows.Count, 2).End(xlUp).Row
  For i = 1 To lr - 1
    If Cells(i, 2).Interior.ColorIndex = 3 Then
      Set r = mu(c, r): Set c = Cells(i, 2)
    Else
      Set c = Nothing
    End If
  Next
  If Cells(lr, 2).Interior.ColorIndex = 3 Then Set r = mu(Cells(lr, 2), r)
  If Not r Is Nothing Then r.EntireRow.Delete
End Sub
фрилансер Excel, VBA - контакты в профиле
"Совершенствоваться не обязательно. Выживание — дело добровольное." Э.Деминг
 
 
 
#10
04.02.2013 12:54:44
Чтобы не флудить, решил спросить в этой же теме.
А как удалить строку в зависимости от цвета ячейки? Например, мне надо удалить строку, если в ней хоть одна ячейка красная.
Вот это почему-то не работает

Sub DeleteRedRows()
   Dim i As Long
   For i = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
       If Rows(i).Interior.ColorIndex = 3 Then Rows(i).Delete
   Next
End Sub
 
 
 
#11
04.02.2013 13:02:44
Цитата
Derian Fox пишет: Вот это почему-то не работает
потому что
Код
?
1
If Rows(i).Interior.ColorIndex = 3 Then

проверяет цвет закраски КАЖДОЙ ячейки в указанном диапазоне (строке).
и вернет число только в том случае, если ВСЕ цвета будут одинаковы.
иначе возвращается Null

Вам же нужен перебор ячеек в строке - до тех пор, пока не встретите хоть одну нужного цвета или не убедитесь, что ни одна не имеет нужного цвета.
фрилансер Excel, VBA - контакты в профиле
"Совершенствоваться не обязательно. Выживание — дело добровольное." Э.Деминг
 
 
 
#12
04.02.2013 14:07:52
Он оно че (с)...
Ну суть проблемы то я понял. А как пофиксить?)
Я так понимаю, надо добавить For each.
Изменено: Derian Fox - 04.02.2013 14:11:59
 
 
 
#13
04.02.2013 14:11:11
а я вам написал :)
Цитата
Derian Fox пишет: А как удалить строку...
Цитата
ikki пишет: Вам же нужен перебор ячеек в строке...
вы ведь, как я вижу, пытаетесь править макросы?
или вам нужен конкретный пример кода?
наверное, так и надо говорить, ага?
без намёков  ;)
фрилансер Excel, VBA - контакты в профиле
"Совершенствоваться не обязательно. Выживание — дело добровольное." Э.Деминг
 
 
 
#14
04.02.2013 14:13:37
Цитата
ikki пишет:
вы ведь, как я вижу, пытаетесь править макросы?
или вам нужен конкретный пример кода?
наверное, так и надо говорить, ага?
без намёков;)

Я пытаюсь править, но пока безуспешно)
Да, мне надо готовый вариант. Нагуглить я так и не смог по свою ситуацию.
 
 
 
#15
04.02.2013 14:20:12
Т.е. за почти месяц прогресса нет...
У Вас ведь есть уже один цикл перебора строк - добавьте внутрь цик перебора ячеек строки:

Код
?
1
2
3
4
5
6
7
8
Sub DeleteRedRows()
    Dim i As Long, c As Range
    For i = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
        For Each c In Intersect(ActiveSheet.UsedRange, Rows(i)).Cells
            If c.Interior.ColorIndex = 3 Then Rows(i).Delete: Exit For
        Next
    Next
End Sub
 
 
 
#16
04.02.2013 14:23:14
пробуем
Код
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub DeleteRedRows()
  Dim i&, j&, xr&, xc&, f As Boolean
  With ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)
    xr = .Row
    xc = .Column
  End With
  For i = xr To 1 Step -1
    f = False
    For j = 1 To xc
      If Cells(i, j).Interior.ColorIndex = 3 Then f = True: Exit For
    Next
    If f Then Rows(i).Delete
  Next
End Sub
фрилансер Excel, VBA - контакты в профиле
"Совершенствоваться не обязательно. Выживание — дело добровольное." Э.Деминг
 
 
 
#17
04.02.2013 14:31:08
Hugo, прогресс есть, но увы, не в этой сфере.
Спасибо за макрос.
 
 
 
#18
04.02.2013 20:05:18
ikki, всё, что касается Union, оооочень медленно работает при большом количестве объединений. Сравните в этом примере вариант "nilem 1" с другими, и вы ощутите разницу.
Посмотрите мой вариант во вложении, хотя SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete тоже не самый быстрый способ удаления строк. Строки удаляются быстрее всего тогда, когда они собраны вместе. Сделать это можно либо копированием/вставкой, либо сортировкой - варианты ANik1 и nilem 3 соответственно.
Вообще, Excel такая хитрая штука, что почти все операции можно решить не прибегая к циклическому перебору ячеек, и зачастую не одним вариантом. Для небольшого количества строк это незаметно, но когда данных много, тормоза начинают напрягать и все с этим периодически сталкиваются.
 
 
 
#19
05.02.2013 16:09:47
По поводу "удалить строку, если в ней хоть одна ячейка красная" - что-то мы совсем забыли, что у метода Find есть параметр SearchFormat  :)
 
 
 
Страницы: 1
Читают тему
Loading...