Всем вечер добрый! Возникла следующая потребность: выделять в столбце А (пример) заливкой разными цветами дублей значений.(одинаковые значения заливаются одинаковым цветом) для последующей их обработки. Макрос под это дело нашелся, но вот для пущего удобства хотелось бы, чтобы одинаковые значения (и цвета) группировалась вместе. Штатная экселевая сортировка с этой задачей не совсем справляется: она строки по всей длине сортирует, а надо только в заданном диапазоне - от А до М. Ну и чтобы совсем стало удобно, хотелось бы чтобы дубли сразу заливались цветами конкретно в столбце А., а не в производно выделенном. Пример, после работы макроса прилагаю. Сам макрос там есть. Сюда выкладывать опасаюсь, так не умею делать этого в соответствии с правилами форума - накосячу и модеры в очередной раз мне задницу надерут. P.S. Все таки рискнул и вставил
[vba]
Код
Sub ВыделитьДубликатыРазнымиЦветами() On Error Resume Next Colors = Array(65535, 15773696, 255, 5287936, 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 For i& = 1 To dupes.Count 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
[/vba]
Всем вечер добрый! Возникла следующая потребность: выделять в столбце А (пример) заливкой разными цветами дублей значений.(одинаковые значения заливаются одинаковым цветом) для последующей их обработки. Макрос под это дело нашелся, но вот для пущего удобства хотелось бы, чтобы одинаковые значения (и цвета) группировалась вместе. Штатная экселевая сортировка с этой задачей не совсем справляется: она строки по всей длине сортирует, а надо только в заданном диапазоне - от А до М. Ну и чтобы совсем стало удобно, хотелось бы чтобы дубли сразу заливались цветами конкретно в столбце А., а не в производно выделенном. Пример, после работы макроса прилагаю. Сам макрос там есть. Сюда выкладывать опасаюсь, так не умею делать этого в соответствии с правилами форума - накосячу и модеры в очередной раз мне задницу надерут. P.S. Все таки рискнул и вставил
[vba]
Код
Sub ВыделитьДубликатыРазнымиЦветами() On Error Resume Next Colors = Array(65535, 15773696, 255, 5287936, 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 For i& = 1 To dupes.Count 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
Протестировал макрос сегодня в "боевых условиях" - не, не работает как надо. По цвету заливки не группирует, иногда вообще значения с цветом удаляет и непонятно по какому признаку. В общем вопрос пока остается открытым.
Протестировал макрос сегодня в "боевых условиях" - не, не работает как надо. По цвету заливки не группирует, иногда вообще значения с цветом удаляет и непонятно по какому признаку. В общем вопрос пока остается открытым.Serge1400
Сергей, привет! Так хотел? Я просто тупо отсортировал диапазон А2:М14 по первому столбцу (столбец М - это цифра 13 в самом низу кода, 13-й по счету столбец) [vba]
Код
Sub ВыделитьДубликатыРазнымиЦветами() On Error Resume Next Colors = Array(65535, 15773696, 255, 5287936, 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 r0_ = 2 r1_ = Range("A" & Rows.Count).End(xlUp).Row If r1_ < r0_ Then Exit Sub End If Set ra = Range("A" & r0_).Resize(r1_ - r0_ + 1) 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) End If If Err Then dupes.Add CStr(cell.Value), CStr(cell.Value) End If Next cell For i& = 1 To dupes.Count 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 With ActiveSheet.Sort .SetRange Range("A" & r0_).Resize(r1_ - r0_ + 1, 13) .Apply End With Application.ScreenUpdating = True End Sub
[/vba] [p.s.]Ненавижу двоеточия в кодах макросов! Кое-кто (знаю, есть любители короткой записи) со мной не согласится, но я предпочитаю написать лишнюю строчку. Зато код читается легко и без напряжения и сразу видно, где If начинается и где заканчивается
Сергей, привет! Так хотел? Я просто тупо отсортировал диапазон А2:М14 по первому столбцу (столбец М - это цифра 13 в самом низу кода, 13-й по счету столбец) [vba]
Код
Sub ВыделитьДубликатыРазнымиЦветами() On Error Resume Next Colors = Array(65535, 15773696, 255, 5287936, 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 r0_ = 2 r1_ = Range("A" & Rows.Count).End(xlUp).Row If r1_ < r0_ Then Exit Sub End If Set ra = Range("A" & r0_).Resize(r1_ - r0_ + 1) 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) End If If Err Then dupes.Add CStr(cell.Value), CStr(cell.Value) End If Next cell For i& = 1 To dupes.Count 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 With ActiveSheet.Sort .SetRange Range("A" & r0_).Resize(r1_ - r0_ + 1, 13) .Apply End With Application.ScreenUpdating = True End Sub
[/vba] [p.s.]Ненавижу двоеточия в кодах макросов! Кое-кто (знаю, есть любители короткой записи) со мной не согласится, но я предпочитаю написать лишнюю строчку. Зато код читается легко и без напряжения и сразу видно, где If начинается и где заканчивается_Boroda_
Sub U() Dim Msg As String Dim Response As Long Dim MyCollection As Collection Dim Rng As Range Dim Cell As Range Dim vNum As Variant Dim i&
lr = Sheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr Set Rng = Sheets("Лист1").Range("A2:A" & lr) Set MyCollection = New Collection On Error Resume Next For Each Cell In Rng.Cells MyCollection.Add Cell.Interior.Color, CStr(Cell.Interior.Color) Next Cell Next i On Error GoTo 0 For Each vNum In MyCollection ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Clear ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Add(Range("A1"), _ xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = vNum With ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort
.Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Next vNum Exit Sub End Sub
[/vba] Исправляюсь. На более универсальный вариант. Время появилось. С фильтрами нет времени дописывать. Обязательно в верхней строчке на длину таблицы должен стоять фильтр.
[vba]
Код
Sub U() Dim Msg As String Dim Response As Long Dim MyCollection As Collection Dim Rng As Range Dim Cell As Range Dim vNum As Variant Dim i&
lr = Sheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr Set Rng = Sheets("Лист1").Range("A2:A" & lr) Set MyCollection = New Collection On Error Resume Next For Each Cell In Rng.Cells MyCollection.Add Cell.Interior.Color, CStr(Cell.Interior.Color) Next Cell Next i On Error GoTo 0 For Each vNum In MyCollection ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Clear ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Add(Range("A1"), _ xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = vNum With ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort
.Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Next vNum Exit Sub End Sub
[/vba] Исправляюсь. На более универсальный вариант. Время появилось. С фильтрами нет времени дописывать. Обязательно в верхней строчке на длину таблицы должен стоять фильтр.ant6729
Сообщение отредактировал ant6729 - Четверг, 15.06.2017, 20:38
Всех благодарю за помощь! _Boroda_, Саша, как понял, твой макрос еще и отсортировать должен по цвету значения. Цветами разными все заливается, вот чето только по цвету не сортируется ничего в указанном тобой диапазоне
Всех благодарю за помощь! _Boroda_, Саша, как понял, твой макрос еще и отсортировать должен по цвету значения. Цветами разными все заливается, вот чето только по цвету не сортируется ничего в указанном тобой диапазоне Serge1400
Сообщение отредактировал Serge1400 - Четверг, 29.06.2017, 23:28
Переписал и чуток потискал. Не, мне предыдущий больше интересен, хоть он и предполагает некоторый "ручной труд" для получения конечного результата. Крайний же по цвету сортирует все в самом конце таблицы ( и заголовок заодно). А меня в таблице 770 строк - пока туда сползешь. А как в предложенном макросе ввести второе условие, чтоб получилось вот так: при совпадении значений в столбце A и С заливать одинаковым цветом?
Переписал и чуток потискал. Не, мне предыдущий больше интересен, хоть он и предполагает некоторый "ручной труд" для получения конечного результата. Крайний же по цвету сортирует все в самом конце таблицы ( и заголовок заодно). А меня в таблице 770 строк - пока туда сползешь. А как в предложенном макросе ввести второе условие, чтоб получилось вот так: при совпадении значений в столбце A и С заливать одинаковым цветом?Serge1400
Сообщение отредактировал Serge1400 - Воскресенье, 02.07.2017, 23:38
1. "и заголовок заодно" - какой пример - такой ответ. Где у тебя в файле заголовок? Если заголовок есть, то начинать нужно не с r0_=2, а с r0_=3 или любой нужной строки 2. "по цвету сортирует все в самом конце таблицы" не по цвету в конце таблицы, а обычная сортировка по значениям в ячейках. Какие значения больше - те и ниже. Если хочешь, чтобы бОльшие были наверху, то в строку с Add нужно добавить условие сортировки. Вот так [vba]
[/vba]Или можно перепрыгивать вниз таблицы c помощью [vba]
Код
Application.Goto
[/vba] А по двум столбцам все аналогично
1. "и заголовок заодно" - какой пример - такой ответ. Где у тебя в файле заголовок? Если заголовок есть, то начинать нужно не с r0_=2, а с r0_=3 или любой нужной строки 2. "по цвету сортирует все в самом конце таблицы" не по цвету в конце таблицы, а обычная сортировка по значениям в ячейках. Какие значения больше - те и ниже. Если хочешь, чтобы бОльшие были наверху, то в строку с Add нужно добавить условие сортировки. Вот так [vba]
Саша.! Хошь убивай, хошь не убивай, но объясни мне бестолковому как мне переназначить в макросе столбец по местонахождению второго условия в оригинале моей таблицы Я два дня тыркаюсь и методом тыка пытаюсь вычислить какую и где цифирку надо поменять. И хорошо бы еще и по цвету чтоб сортировалось :pray
Саша.! Хошь убивай, хошь не убивай, но объясни мне бестолковому как мне переназначить в макросе столбец по местонахождению второго условия в оригинале моей таблицы Я два дня тыркаюсь и методом тыка пытаюсь вычислить какую и где цифирку надо поменять. И хорошо бы еще и по цвету чтоб сортировалось :praySerge1400
Ну мы же совпадающие по первому и второму условию значения в столбце А красим одинаковым цветом - а то у меня в таблице 750 строк и они по всей длине растащились группами. Вот и хотелось бы сортировать так чтобы прям сначала столбца шли скажем синенькие, потом красненькие и т.п. P/S/ Ура - меня наконец то реабилитировали. Сняли с меня отрицательную 40% карму.
Ну мы же совпадающие по первому и второму условию значения в столбце А красим одинаковым цветом - а то у меня в таблице 750 строк и они по всей длине растащились группами. Вот и хотелось бы сортировать так чтобы прям сначала столбца шли скажем синенькие, потом красненькие и т.п. P/S/ Ура - меня наконец то реабилитировали. Сняли с меня отрицательную 40% карму. Serge1400
Сообщение отредактировал Serge1400 - Вторник, 04.07.2017, 22:49