Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Выделять ячейки цветами с определенной нужной информацией, макрос
 
#1
19.08.2016 10:27:12
IПытался написать макрос, который будет выделять ячейки цветами с определенной нужной информацией. Например если в ячейках в тексте есть запись К50 то все ячейки где присутствует такое обозначение окрасятся в один цвет, и дальше по списку, все ячейки с К48 другой цвет и тд.
Написал это
Код
Sub ВыделитьЦветами()
Dim z, z1, i&: z = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Value
    ReDim z1(1 To UBound(z), 1 To 1)                'класс прочности
        For i = 1 To UBound(z)
            If InStrRev(z(i, 1), "К52") Then z1(i, 1) = "К52"
            If InStrRev(z(i, 1), "К50") Then z1(i, 1) = "К50"
            If InStrRev(z(i, 1), "К48") Then z1(i, 1) = "К48"
    On Error Resume Next
    Colors = Array(12900829, 15849925, 14408946, 14610923, 15986394, 14281213, 14277081, _
                   9944516, 14994616, 12040422, 12379352, 15921906, 14336204, 15261367, 14281213)
    Dim coll As New Collection, dupes As New Collection, _
        cols As New Collection, ra As Range, cell As Range, n&
    Err.Clear: Set ra = Intersect(Selection, ActiveSheet.UsedRange)
    If Err Then Exit Sub
    ra.Interior.ColorIndex = xlColorIndexNone: Application.ScreenUpdating = False
    For Each cell In ra.Cells
        Err.Clear: If Len(Trim(cell)) Then coll.Add CStr(cell.Value), CStr(cell.Value)
        If Err Then dupes.Add CStr(cell.Value), CStr(cell.Value)
    Next cell
        n = n Mod (UBound(Colors) + 1): cols.Add Colors(n), dupes(i): n = n + 1
    Next
    For Each cell In ra.Cells
        cell.Interior.Color = cols(CStr(cell.Value))
    Next cell
    Application.ScreenUpdating = True
End Sub

Запускаю макрос ошибки ни какой не выскакивает, но по завершению процедуры ничего не меняется. В чем причина, что можно изменить чтоб он заработал как нужно.
Изменено: MO_ORDA - 19.08.2016 15:41:23
 
 
 
#2
20.08.2016 11:39:03
Код
Sub ВыделитьЦветами()
    
    'при появлении новых данных, увеличьте число 3
    Dim arrColors(1 To 3, 1 To 2)
    Dim rng As Range, cel As Range, i As Long
    
    'привязка к определенному тексту цвета
    arrColors(1, 1) = "К52": arrColors(1, 2) = 12900829
    arrColors(2, 1) = "К50": arrColors(2, 2) = 15849925
    arrColors(3, 1) = "К48": arrColors(3, 2) = 14408946
    
    On Error Resume Next
        Set rng = Intersect(Selection, ActiveSheet.UsedRange)
    On Error GoTo 0
    If rng Is Nothing Then
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    rng.Interior.ColorIndex = xlColorIndexNone
    
    For Each cel In rng.Cells
        If Len(Trim(cel.Value)) <> 0 Then
            For i = 1 To UBound(arrColors)
                If InStr(cel.Value, arrColors(i, 1)) <> 0 Then
                    cel.Interior.Color = arrColors(i, 2)
                    Exit For
                End If
            Next i
        End If
    Next cel
    
    Application.ScreenUpdating = True
    
End Sub
 
 
 
#3
20.08.2016 11:48:36
Цитата
MO_ORDA написал:
будет выделять ячейки цветами с определенной нужной информацией
Интересно, Вы - Конечный Пользователь этого алгоритма или Генератор Автоматизации?
Можно увидеть текст Инструкции для Конечного Пользователя?
 
 
 
#4
20.08.2016 14:41:03
Вообще хочу просто научиться пользоваться VBA excel, а что сделать с помощью VBA отталкиваюсь от рабоды. Например приходится постоянно просчитывать дталали по разным формулам чтобы узнать нужные значения. Попробовал написать калькулятор ( банально конечно, но о макрасах я узнал всего неделю назад и с чего то начинать нужно). Так вот написать его получилось, но значения получались не верные, потому что не получалось округлять. Либо ошибка, либо что то не суразное получалось, спросил здесь, мне подсказали как правильно прописать, остальное доделал сам. Но щас мучаюсь с Checkbox что бы заменить некоторые кнопки, не получается пока что, но пробую.
С этим макросом который выделяет цветами такая же ситуация, делал макрос, все получилось и работает (хотя по сути простые операции но начинать с чего то нужно), но выделять цветами что нужно не получалось, создал сдесь тему.
 
 
 
#5
20.08.2016 15:07:47
Раз пошел такой разговор, если не составит труда подскажите как провести процидуру... удалено
 
 
 
#6
20.08.2016 15:54:38
Цитата
MO_ORDA написал:
Раз пошел такой разговор, если не составит труда подскажите как провести процидуру.
Создайте новую тему, т.к. этот вопрос уже не имеет никакого отношения к теме.
 
 
 
#7
21.08.2016 07:14:11
Можно существенно проще, без циклов по ячейкам:
Код
Sub qq()
    Dim rng As Range, i As Integer, x
    Set rng = Intersect(Selection, ActiveSheet.UsedRange)
    With Application
        .FindFormat.Clear: .ReplaceFormat.Clear: .ScreenUpdating = False
        rng.Interior.ColorIndex = xlNone
        For Each x In Array("К52", "К50", "К48")
            i = i + 1
            .ReplaceFormat.Interior.Color = Choose(i, 12900829, 15849925, 14408946)
            rng.Replace x, x, LookAt:=xlPart, ReplaceFormat:=True
        Next
    End With
End Sub
Выделите требуемый диапазон и запустите макрос.
Значения "К52", "К50" и "К48" в коде макроса заданы русскими буквами. Если нужно - измените.
Изменено: SAS888 - 21.08.2016 07:25:30
Чем шире угол зрения, тем он тупее.
 
 
 
Страницы: 1
Читают тему
Наверх