Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Выделение дубликатов таблицы различными цветами , дата - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Выделение дубликатов таблицы различными цветами , дата (Макросы/Sub)
Выделение дубликатов таблицы различными цветами , дата
Vetya Дата: Пятница, 27.04.2018, 12:04 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Приветствую всех.
Есть таблица с 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
[/vba]

Автор - Vetya
Дата добавления - 27.04.2018 в 12:04
StoTisteg Дата: Пятница, 27.04.2018, 12:14 | Сообщение № 2
Группа: Авторы
Ранг: Ветеран
Сообщений: 920
Репутация: 78 ±
Замечаний: 0% ±

Excel 2010
Vetya, просто замените [vba]
Код
Set ra = Intersect(Selection, ActiveSheet.UsedRange)
[/vba] на [vba]
Код
Set ra =ActiveSheet.UsedRange
[/vba] и будет работать со всей таблицей.


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
СообщениеVetya, просто замените [vba]
Код
Set ra = Intersect(Selection, ActiveSheet.UsedRange)
[/vba] на [vba]
Код
Set ra =ActiveSheet.UsedRange
[/vba] и будет работать со всей таблицей.

Автор - StoTisteg
Дата добавления - 27.04.2018 в 12:14
StoTisteg Дата: Пятница, 27.04.2018, 12:17 | Сообщение № 3
Группа: Авторы
Ранг: Ветеран
Сообщений: 920
Репутация: 78 ±
Замечаний: 0% ±

Excel 2010
Сортировку тоже несложно сделать, но приложите, плз, файл, а не картинки.


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
СообщениеСортировку тоже несложно сделать, но приложите, плз, файл, а не картинки.

Автор - StoTisteg
Дата добавления - 27.04.2018 в 12:17
Vetya Дата: Пятница, 27.04.2018, 12:27 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
он у меня больше 100кб :( сейчас постараюсь уменьшить
 
Ответить
Сообщениеон у меня больше 100кб :( сейчас постараюсь уменьшить

Автор - Vetya
Дата добавления - 27.04.2018 в 12:27
StoTisteg Дата: Пятница, 27.04.2018, 12:39 | Сообщение № 5
Группа: Авторы
Ранг: Ветеран
Сообщений: 920
Репутация: 78 ±
Замечаний: 0% ±

Excel 2010
Да просто вбейте то, что на картинках. Этого хватит.


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
СообщениеДа просто вбейте то, что на картинках. Этого хватит.

Автор - StoTisteg
Дата добавления - 27.04.2018 в 12:39
Vetya Дата: Пятница, 27.04.2018, 12:48 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Vetya, просто замените
Set ra = Intersect(Selection, ActiveSheet.UsedRange)

на
Set ra =ActiveSheet.UsedRange

и будет работать со всей таблицей.

А как сделать чтобы автоматически выделялось при добавлении новой строки?
 
Ответить
СообщениеVetya, просто замените
Set ra = Intersect(Selection, ActiveSheet.UsedRange)

на
Set ra =ActiveSheet.UsedRange

и будет работать со всей таблицей.

А как сделать чтобы автоматически выделялось при добавлении новой строки?

Автор - Vetya
Дата добавления - 27.04.2018 в 12:48
StoTisteg Дата: Пятница, 27.04.2018, 12:51 | Сообщение № 7
Группа: Авторы
Ранг: Ветеран
Сообщений: 920
Репутация: 78 ±
Замечаний: 0% ±

Excel 2010
Вот для того, чтобы это показать, мне и нужен файл.


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
СообщениеВот для того, чтобы это показать, мне и нужен файл.

Автор - StoTisteg
Дата добавления - 27.04.2018 в 12:51
Vetya Дата: Пятница, 27.04.2018, 12:53 | Сообщение № 8
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Залил на дропми) ссылка rules
 
Ответить
СообщениеЗалил на дропми) ссылка rules

Автор - Vetya
Дата добавления - 27.04.2018 в 12:53
StoTisteg Дата: Пятница, 27.04.2018, 12:59 | Сообщение № 9
Группа: Авторы
Ранг: Ветеран
Сообщений: 920
Репутация: 78 ±
Замечаний: 0% ±

Excel 2010
[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]
В модуль листа. Не проверено, как Вы понимаете.


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
Сообщение[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
Дата добавления - 27.04.2018 в 12:59
Vetya Дата: Пятница, 27.04.2018, 13:39 | Сообщение № 10
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Не работает :(

У меня в этом листе есть уже вот такое вот, и да - это второй лист "Итог" все вноситься в основной первый , а тут только табличка итоговая
[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]


Сообщение отредактировал Vetya - Пятница, 27.04.2018, 13:40
 
Ответить
СообщениеНе работает :(

У меня в этом листе есть уже вот такое вот, и да - это второй лист "Итог" все вноситься в основной первый , а тут только табличка итоговая
[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]

Автор - Vetya
Дата добавления - 27.04.2018 в 13:39
StoTisteg Дата: Пятница, 27.04.2018, 14:00 | Сообщение № 11
Группа: Авторы
Ранг: Ветеран
Сообщений: 920
Репутация: 78 ±
Замечаний: 0% ±

Excel 2010
У меня в этом листе есть уже вот такое вот

И как это мешает? Эти два кода можно просто механически слить.
все вноситься в основной первый , а тут только табличка итоговая

Не важно, что куда вносится. Важно с каким листом Вам нужно работать.


Проверь всё. ThisWorkbook.Save. On Error Resume Next.

Сообщение отредактировал StoTisteg - Пятница, 27.04.2018, 14:02
 
Ответить
Сообщение
У меня в этом листе есть уже вот такое вот

И как это мешает? Эти два кода можно просто механически слить.
все вноситься в основной первый , а тут только табличка итоговая

Не важно, что куда вносится. Важно с каким листом Вам нужно работать.

Автор - StoTisteg
Дата добавления - 27.04.2018 в 14:00
Vetya Дата: Пятница, 27.04.2018, 14:11 | Сообщение № 12
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Set ra = Intersect ActiveSheet.UsedRange

это вот выделяет Syntax error
 
Ответить
СообщениеSet ra = Intersect ActiveSheet.UsedRange

это вот выделяет Syntax error

Автор - Vetya
Дата добавления - 27.04.2018 в 14:11
StoTisteg Дата: Пятница, 27.04.2018, 14:26 | Сообщение № 13
Группа: Авторы
Ранг: Ветеран
Сообщений: 920
Репутация: 78 ±
Замечаний: 0% ±

Excel 2010
Тьфу. Intersect лишний.


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
СообщениеТьфу. Intersect лишний.

Автор - StoTisteg
Дата добавления - 27.04.2018 в 14:26
Vetya Дата: Пятница, 04.05.2018, 12:56 | Сообщение № 14
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Спасибо!
 
Ответить
СообщениеСпасибо!

Автор - Vetya
Дата добавления - 04.05.2018 в 12:56
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Выделение дубликатов таблицы различными цветами , дата (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2018 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!