Приветствую всех. Есть таблица с 4 колонками. 1 колонка ФИО 3 колонка текущее дата\время Как сделать макрос который автоматически окрашивает дубли строк(разными цветами) при совпадении в первой колонке, но при этом только на текущую дату (то- есть сегодня) при внесении.
Доп вопрос можно ли сделать автоматическую сортировку при добавлении- опять же на текущую дату, чтобы все строки с одинаковой первой ячейкой(фио)автоматом сортировались друг под другом. Для визуализации чего хотелось бы Было: Стало: Заранее благодарен [offtop] До этого пользовался кнопкой для выделения цветом - но она работает только с выделенным диапазоном а хотелось бы на весь первый столбец и автоматически при добавлении строки [vba]
Код
Sub ВыделитьДубликатыРазнымиЦветами() 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 ' запонимаем значение дубликатов в коллекции dupes 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 For i& = 1 To dupes.Count ' заполняем коллекцию cols цветами для разных дубликатов n = n Mod (UBound(Colors) + 1): cols.Add Colors(n), dupes(i): n = n + 1 Next For Each cell In ra.Cells ' окрашиваем ячейки, если для её значения назначен цвет cell.EntireRow.Interior.Color = cols(CStr(cell.Value)) Next cell Application.ScreenUpdating = True End Sub
[/vba]
Приветствую всех. Есть таблица с 4 колонками. 1 колонка ФИО 3 колонка текущее дата\время Как сделать макрос который автоматически окрашивает дубли строк(разными цветами) при совпадении в первой колонке, но при этом только на текущую дату (то- есть сегодня) при внесении.
Доп вопрос можно ли сделать автоматическую сортировку при добавлении- опять же на текущую дату, чтобы все строки с одинаковой первой ячейкой(фио)автоматом сортировались друг под другом. Для визуализации чего хотелось бы Было: Стало: Заранее благодарен [offtop] До этого пользовался кнопкой для выделения цветом - но она работает только с выделенным диапазоном а хотелось бы на весь первый столбец и автоматически при добавлении строки [vba]
Код
Sub ВыделитьДубликатыРазнымиЦветами() 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 ' запонимаем значение дубликатов в коллекции dupes 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 For i& = 1 To dupes.Count ' заполняем коллекцию cols цветами для разных дубликатов n = n Mod (UBound(Colors) + 1): cols.Add Colors(n), dupes(i): n = n + 1 Next For Each cell In ra.Cells ' окрашиваем ячейки, если для её значения назначен цвет cell.EntireRow.Interior.Color = cols(CStr(cell.Value)) Next cell Application.ScreenUpdating = True End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
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& Set ra = Intersect ActiveSheet.UsedRange With ActiveSheet.Sort .SortFields.Clear .SortFields.Add Key:=Cells(1, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SetRange ra .Header = xlYes .SortMethod = xlPinYin .Apply End With ra.Interior.ColorIndex = xlColorIndexNone: Application.ScreenUpdating = False For Each cell In ra.Cells ' запонимаем значение дубликатов в коллекции dupes 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 For i& = 1 To dupes.Count ' заполняем коллекцию cols цветами для разных дубликатов n = n Mod (UBound(Colors) + 1): cols.Add Colors(n), dupes(i): n = n + 1 Next For Each cell In ra.Cells ' окрашиваем ячейки, если для её значения назначен цвет cell.EntireRow.Interior.Color = cols(CStr(cell.Value)) Next cell Application.ScreenUpdating = True
End Sub
[/vba] В модуль листа. Не проверено, как Вы понимаете.
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
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& Set ra = Intersect ActiveSheet.UsedRange With ActiveSheet.Sort .SortFields.Clear .SortFields.Add Key:=Cells(1, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SetRange ra .Header = xlYes .SortMethod = xlPinYin .Apply End With ra.Interior.ColorIndex = xlColorIndexNone: Application.ScreenUpdating = False For Each cell In ra.Cells ' запонимаем значение дубликатов в коллекции dupes 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 For i& = 1 To dupes.Count ' заполняем коллекцию cols цветами для разных дубликатов n = n Mod (UBound(Colors) + 1): cols.Add Colors(n), dupes(i): n = n + 1 Next For Each cell In ra.Cells ' окрашиваем ячейки, если для её значения назначен цвет cell.EntireRow.Interior.Color = cols(CStr(cell.Value)) Next cell Application.ScreenUpdating = True
End Sub
[/vba] В модуль листа. Не проверено, как Вы понимаете.StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
У меня в этом листе есть уже вот такое вот, и да - это второй лист "Итог" все вноситься в основной первый , а тут только табличка итоговая [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
For Each cell In Target If Not Intersect(cell, Range("B2:B100")) Is Nothing Then With cell.Offset(0, 1) .Value = Now .EntireColumn.AutoFit End With End If Next cell End Sub
[/vba]
Не работает
У меня в этом листе есть уже вот такое вот, и да - это второй лист "Итог" все вноситься в основной первый , а тут только табличка итоговая [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
For Each cell In Target If Not Intersect(cell, Range("B2:B100")) Is Nothing Then With cell.Offset(0, 1) .Value = Now .EntireColumn.AutoFit End With End If Next cell End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
сейчас постараюсь уменьшить
