Подскажите пожалуйста, возможно ли автоматически расшкрашивать одинаковые строки в списке, но каждую пару в разный цвет? В примере всё наглядно, в столбце A, то, чего можно добиться, с помощью условного форматирования, в столбце B, то, чего хотелось бы добиться. Когда список огромен, большая проблема в нём сориентироваться, УФ в таком случае скорее даже мешается, т.к. получается всё одним цветом, следовательно целевая задача не выполняется.
Всех с наступившим Новым годом!
Подскажите пожалуйста, возможно ли автоматически расшкрашивать одинаковые строки в списке, но каждую пару в разный цвет? В примере всё наглядно, в столбце A, то, чего можно добиться, с помощью условного форматирования, в столбце B, то, чего хотелось бы добиться. Когда список огромен, большая проблема в нём сориентироваться, УФ в таком случае скорее даже мешается, т.к. получается всё одним цветом, следовательно целевая задача не выполняется.unk
Sub Raskraska() Dim x, i&, j&, s$, TmpS$ Dim bu As Boolean With Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row + 1) x = .Value ' .Resize(, 2).Interior.Color = xlNone End With For i = 1 To UBound(x) s = x(i, 1) & "~" & x(i, 2) If TmpS <> s Then If bu Then Cells(j, 1).Resize(i - j, 2).Interior.Color = 15853276 j = i TmpS = s bu = Not bu End If Next i End Sub
Sub Raskraska() Dim x, i&, j&, s$, TmpS$ Dim bu As Boolean With Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row + 1) x = .Value ' .Resize(, 2).Interior.Color = xlNone End With For i = 1 To UBound(x) s = x(i, 1) & "~" & x(i, 2) If TmpS <> s Then If bu Then Cells(j, 1).Resize(i - j, 2).Interior.Color = 15853276 j = i TmpS = s bu = Not bu End If Next i End Sub
nilem, Привет, весьма интересно, спасибо большое! Не могли бы объяснить, как настраивать под себя? Например, где задаётся отступ сверху? Или как сделать, чтобы использовался только один столбец как параметр?
nilem, Привет, весьма интересно, спасибо большое! Не могли бы объяснить, как настраивать под себя? Например, где задаётся отступ сверху? Или как сделать, чтобы использовался только один столбец как параметр?unk
For i = 1 To UBound(x) - если есть строка заголовков, то со второй строки: For i = 2 To UBound(x) s = x(i, 1) & "~" & x(i, 2) - если нужен только 1-й столбец, то s = x(i, 1) , если только 2-й, то s = x(i, 2)
For i = 1 To UBound(x) - если есть строка заголовков, то со второй строки: For i = 2 To UBound(x) s = x(i, 1) & "~" & x(i, 2) - если нужен только 1-й столбец, то s = x(i, 1) , если только 2-й, то s = x(i, 2)nilem
nilem, Подскажите пожалуйста, как сделать, чтобы этот макрос действовал только на выделенный диапазон с включенным фильтром? Например выделил $B$7:$B$266 и раскрасил только видимые пары.
Так работает вот этот код для вставки в видимое:
[vba]
Код
Sub PasteToVisible() Dim copyrng As Range, pasterng As Range Dim cell As Range, i As Long
'запрашиваем у пользователя по очереди диапазоны копирования и вставки Set copyrng = Application.InputBox("Диапазон копирования", "Запрос", Type:=8) Set pasterng = Application.InputBox("Диапазон вставки", "Запрос", Type:=8)
'проверяем, чтобы они были одинакового размера If pasterng.SpecialCells(xlCellTypeVisible).Cells.Count <> copyrng.Cells.Count Then MsgBox "Диапазоны копирования и вставки разного размера!", vbCritical Exit Sub End If
'переносим данные из одного диапазона в другой только в видимые ячейки i = 1 For Each cell In pasterng If cell.EntireRow.Hidden = False Then cell.Value = copyrng.Cells(i).Value i = i + 1 End If Next cell End Sub
[/vba]
nilem, Подскажите пожалуйста, как сделать, чтобы этот макрос действовал только на выделенный диапазон с включенным фильтром? Например выделил $B$7:$B$266 и раскрасил только видимые пары.
Так работает вот этот код для вставки в видимое:
[vba]
Код
Sub PasteToVisible() Dim copyrng As Range, pasterng As Range Dim cell As Range, i As Long
'запрашиваем у пользователя по очереди диапазоны копирования и вставки Set copyrng = Application.InputBox("Диапазон копирования", "Запрос", Type:=8) Set pasterng = Application.InputBox("Диапазон вставки", "Запрос", Type:=8)
'проверяем, чтобы они были одинакового размера If pasterng.SpecialCells(xlCellTypeVisible).Cells.Count <> copyrng.Cells.Count Then MsgBox "Диапазоны копирования и вставки разного размера!", vbCritical Exit Sub End If
'переносим данные из одного диапазона в другой только в видимые ячейки i = 1 For Each cell In pasterng If cell.EntireRow.Hidden = False Then cell.Value = copyrng.Cells(i).Value i = i + 1 End If Next cell End Sub