Страницы: 1
RSS
Не работает УФ "повторяющиеся значения"
 
Доброго времени! Не работает УФ "повторяющиеся значения", предполагаю, проблема кроется в том, что у меня в ячейках слишком много слов и цифр, так как при сокращении длинны предложения, в ячейке, всё работает, не подскажите как решить проблему?
 
Да, Вы правы, УФ работает, если количество символов в ячейке не более 255. Это можно проверить опытным путем, оставив в ячейках 255 символов. Если затем добавить еще по одному символу, то перестает работать.
 
1.Сравнивать записи до 255 знаков (включительно)
2.Прописать формулу
3.Использовать макросы.
«Бритва Оккама» или «Принцип Калашникова»?
 
Не поможете макросом, с формулой думаю будет проблематично слишком много позиций копм закипит(
 
Можно и набросать. Какие условия?
В первом столбце все значения которые повторяются выделяются цветом, к примеру красным?
«Бритва Оккама» или «Принцип Калашникова»?
 
Да самый простой способ, все повторы выделяются красным цветом. но без ограничения количества знаков
 
Код
Sub Закрасить_повторы()

    Dim arrSrc(), arrPovt() As Boolean
    Dim lr As Long, i As Long, ii As Long
    
    Application.ScreenUpdating = False
    
    lr = Columns("A").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arrSrc() = Range("A1:A" & lr).Value
    ReDim arrPovt(1 To UBound(arrSrc), 1 To 1)
    
    For i = 1 To UBound(arrSrc)
        arrSrc(i, 1) = LCase(arrSrc(i, 1))
    Next
    
    For i = 1 To UBound(arrSrc) - 1
        If arrPovt(i, 1) = False Then
            For ii = i + 1 To UBound(arrSrc)
                If arrSrc(i, 1) = arrSrc(ii, 1) Then
                    arrPovt(i, 1) = True
                    arrPovt(ii, 1) = True
                End If
            Next
        End If
    Next
    
    For i = 1 To UBound(arrPovt)
        If arrPovt(i, 1) = True Then
            Cells(i, "A").Interior.Color = 11389944
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "Готово!", vbInformation

End Sub
Изменено: Karataev - 07.10.2016 17:37:24
 
Только освободился, появилось время набросать макрос. Смотрю уже Karataev выложил версию.
Выложу и я :). Простым перебором. Пустые не выделяет. На больших количествах строк начинает "думать".
Код
Sub select_replica()
Dim arr, i As Long, j As Long
With ActiveSheet.UsedRange
    .Resize(, 1).Interior.Pattern = xlNone: arr = .Resize(, 1).Value
     For i = 1 To .Rows.Count
        For j = i + 1 To .Rows.Count
            If Not arr(j, 1) = Empty Then If arr(j, 1) = arr(i, 1) Then .Resize(1, 1).Offset(j - 1, 0).Interior.Color = 39423: .Resize(1, 1).Offset(i - 1, 0).Interior.Color = 39423
        Next
     Next
End With
End Sub
«Бритва Оккама» или «Принцип Калашникова»?
 
Спасибо!

Подскажите как в макросе изменить столбик?
 
Оп-па...
Код
Sub select_replica2()
Dim arr, i As Long, j As Long, ColN As Long
With Application: .ScreenUpdating = False: .StatusBar = "Обработка данных...": End With
ColN = 3 'задаем номер столбца
With ActiveSheet.UsedRange.Resize(, 1).Offset(, ColN + ActiveSheet.UsedRange.Column - 2)
.Columns.Interior.Pattern = xlNone: arr = .Columns.Value
     For i = 1 To .Rows.count
        For j = i + 1 To .Rows.count
           If Not arr(j, 1) = Empty Then If arr(j, 1) = arr(i, 1) Then Union(.Rows(j), .Rows(i)).Interior.Color = 39423: Exit For
        Next
     Next
End With
With Application: .ScreenUpdating = True: .StatusBar = False: End With
End Sub
Изменено: bedvit - 10.10.2016 13:29:17 (Добавил в алгоритм элемент повышающий производительность.)
«Бритва Оккама» или «Принцип Калашникова»?
 
Доработал алгоритм, довольно быстро шевелится на любых объемах :)
Код
Sub select_replica3()
Dim arr, i As Long, j As Long, ColN As Long
ColN = 3 'задаем номер столбца
With Application: .ScreenUpdating = False: .StatusBar = "Обработка данных...": End With
With ActiveSheet.UsedRange.Resize(, 1).Offset(, ColN - ActiveSheet.UsedRange.Column)
.Columns.Interior.Pattern = xlNone: arr = .Columns.Value
     For i = 1 To .Rows.count
        For j = i + 1 To .Rows.count
            If IsEmpty(arr(i, 1)) Then Exit For Else If Not IsEmpty(arr(j, 1)) Then If arr(j, 1) = arr(i, 1) Then Union(.Rows(j), .Rows(i)).Interior.Color = 39423: Exit For
        Next
     Next
End With
With Application: .ScreenUpdating = True: .StatusBar = False: End With
End Sub
Изменено: bedvit - 18.10.2016 17:51:47 (Нашел ошибку - исправил.)
«Бритва Оккама» или «Принцип Калашникова»?
 
Что-то зацепила меня задача, решил немного накодить)
Задача (по теме): Выделить цветом в нескольких выделенных (select) несвязанных (но могущих пересекаться) диапазонах (в т.ч. из одной ячейки) все повторяющиеся значения (в т.ч. более 255 знаков) максимально быстро на больших массивах.
Прилагаю свой код. Кто хочет поучаствовать, оптимизировать мой код, создать свой - буду рад участию.
Собственно код:
Код
Sub select_replica4()
Dim arr, x, R As Range, A As Long, i As Long, j As Long, iEnd As Long, jEnd As Long, y As Long, ac, t
Dim Словарь: Set Словарь = CreateObject("Scripting.Dictionary")
t = Timer
With Application: .ScreenUpdating = 0: .DisplayAlerts = 0: .EnableEvents = 0: ac = .Calculation: .Calculation = -4135: .StatusBar = "Обработка данных...": End With
Set R = Intersect(ActiveSheet.UsedRange, Selection)
R.Interior.Pattern = Empty
    
ReDim arr(1 To R.Areas.count)
For A = 1 To R.Areas.count
    arr(A) = R.Areas(A).Value
Next

For A = 1 To R.Areas.count
    iEnd = R.Areas(A).count / R.Areas(A).Columns.count
    jEnd = R.Areas(A).count / R.Areas(A).Rows.count
    y = 0
    For i = 1 To iEnd
        For j = 1 To jEnd
        If iEnd + jEnd = 2 Then x = R.Areas(A).Item(1).Value Else x = arr(A)(i, j)
        y = y + 1
            If Not IsEmpty(x) Then If Not Словарь.Exists(x) Then Словарь.Add x, R.Areas(A).Item(y) Else Union(R.Areas(A).Item(y), Словарь.Item(x)).Interior.Color = 6740479
        Next
    Next
Next
With Application: .ScreenUpdating = 1: .DisplayAlerts = 1: .EnableEvents = 1: .Calculation = ac: .StatusBar = False: End With
Debug.Print "= " & Timer - t
End Sub
Изменено: bedvit - 21.10.2016 16:23:14 (Подкорректировал условия, для лучшего понимания.)
«Бритва Оккама» или «Принцип Калашникова»?
 
Добавил выделение разных групп дубликатов разными цветами.
Набросал функция для приятного глазу цвета.
Не идеал, предложите свое решение?

Результат: 10 тыс ячеек с выделением 6 тыс. ячеек 4 сек.

Тест прилагаю.

Код
Option Explicit
'Автор Б. Виталий В. (bedvit)
'Макрос записан: 21/10/2016
'Редакция: 5 от 25/02/2020
'Действие: выделение разными цветами дубликатов в выделенных диапазонах
Sub select_replica() 'рабочий
Dim arr, x, Rn As Range, s(1) As Long, A As Long, i As Long, j As Long, iEnd As Long, jEnd As Long, Y As Long, ac, t
Dim Dict: Set Dict = CreateObject("Scripting.Dictionary")
t = Timer
If Selection.CountLarge = 1 Then Set Rn = ActiveSheet.UsedRange Else Set Rn = Intersect(ActiveSheet.UsedRange, Selection)
If Rn Is Nothing Then Exit Sub

With Application: .ScreenUpdating = 0: .DisplayAlerts = 0: .EnableEvents = 0: ac = .Calculation: .Calculation = -4135: .StatusBar = "BE: обработка данных...": End With
Rn.Interior.Pattern = Empty
 
ReDim arr(1 To Rn.Areas.Count)
For A = 1 To Rn.Areas.Count
    arr(A) = Rn.Areas(A).Value
Next

For A = 1 To Rn.Areas.Count
    iEnd = Rn.Areas(A).Count / Rn.Areas(A).Columns.Count
    jEnd = Rn.Areas(A).Count / Rn.Areas(A).Rows.Count
    Y = 0
    For i = 1 To iEnd
        For j = 1 To jEnd
        If iEnd + jEnd = 2 Then x = Rn.Areas(A).Item(1).Value Else x = arr(A)(i, j)
        Y = Y + 1
            If Not IsEmpty(x) Then
                If Not Dict.Exists(x) Then
                    s(0) = Y
                    If Y = 1 Then s(1) = 6740479 Else s(1) = Generate_nice_color
                    Dict.Add x, s
                Else
                    Union(Rn.Areas(A).Item(Y), Rn.Areas(A).Item(Dict.Item(x)(0))).Interior.Color = Dict.Item(x)(1)
                End If
            End If
        Next
    Next
Next
With Application: .ScreenUpdating = 1: .DisplayAlerts = 1: .EnableEvents = 1: .Calculation = ac: .StatusBar = False: End With
Debug.Print "= " & Timer - t
MsgBox "Выделено разных групп дубликатов (разными цветами): " & Dict.Count, vbInformation
End Sub

Function Generate_nice_color() As Long
Dim R, G, B
Do
    Randomize
    R = Int(Rnd * 256)
    G = Int(Rnd * 256)
    B = Int(Rnd * 256)
Loop Until R + G + B > 500 And R + G + B < 700
Generate_nice_color = RGB(R, G, B)
End Function
«Бритва Оккама» или «Принцип Калашникова»?
 
bedvit, Доброго дня :)
Я вот таким уже пользуюсь пару лет, даже не помню где нашел.

Код
Sub ВыделитьДубликатыРазнымиЦветами()
    On Error Resume Next
    ' массив цветов, используемых для заливки ячеек-дубликатов
    Colors = Array(12910829, 12920728, 12930627, 12940526, 12950425, 12960324, 12970223, 12980122, 12990021)
    'Colors = Array(12910829)
    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.Interior.Color = cols(CStr(cell.Value))
    Next cell
    Application.ScreenUpdating = True
End Sub

 
Wild.Godlike, да неплохо!
Обгоняет мой вариант.
Пришлось выделит время допилить свой код.
Результат:
1.Быстрее на тестовом стенде (в файле) в 6 раз, чем "ВыделитьДубликатыРазнымиЦветами", за счет быстрой обработки не связных диапазонов. На одном диапазоне/ столбце разрыв меньше, учитывая п.3.
2.Количество цветов 200^3 = 8 млн 3,1 млн. цветов (в вашем файле всего 9, и 10я группа дубликатов уже имеет не уникальный цвет)
3. Функция генерации приятных цветов (Generate_nice_color) и проверка на уникальность цвета каждой группе дубликатов съедают 12% от общего времени выполнения программы. В тесте это время учитывалось.

По п.3 можно подумать, как генерировать гарантированно уникальный цвет, приятного оттенка, с меньшим потреблением ресурсов.

Код
Option Explicit
'Автор Б. Виталий В. (bedvit)
'Макрос записан: 21/10/2016
'Редакция: 6 от 26/02/2020
'Действие: выделение разными цветами дубликатов в выделенных диапазонах
Sub select_replica() 'рабочий
Dim R As Range, Rf As Range, Rc As Range, i As Long, s(3) As Long, ac, t, x, cell
Dim Dict: Set Dict = CreateObject("Scripting.Dictionary")
Dim DictColor: Set DictColor = CreateObject("Scripting.Dictionary")
t = Timer

On Error Resume Next
If Selection.CountLarge = 1 Then
    Set Rf = ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas, 23)
    Set Rc = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, 23)
Else
    Set Rf = Intersect(ActiveSheet.UsedRange, Selection).SpecialCells(xlCellTypeFormulas, 23)
    Set Rc = Intersect(ActiveSheet.UsedRange, Selection).SpecialCells(xlCellTypeConstants, 23)
End If
On Error GoTo 0

With Application: .ScreenUpdating = 0: .DisplayAlerts = 0: .EnableEvents = 0: ac = .Calculation: .Calculation = -4135: .StatusBar = "BE: обработка данных...": End With
Set R = Rf: GoSub Go_
Set R = Rc: GoSub Go_
With Application: .ScreenUpdating = 1: .DisplayAlerts = 1: .EnableEvents = 1: .Calculation = ac: .StatusBar = False: End With
Debug.Print "select_replica = " & Timer - t
MsgBox "Выделено разных групп дубликатов (разными цветами): " & i, vbInformation
Exit Sub
    
Go_:
If Not R Is Nothing Then
    R.Interior.Pattern = Empty
    For Each cell In R.Cells
        If Dict.Exists(cell.Value) Then
            x = Dict.Item(cell.Value)
            If x(3) = 1 Then
                i = i + 1
                If i = 1 Then
                    x(2) = 6740479 ' мой первый :)
                Else
                    Do 'гарантия уникального цвета на группу дубликатов - жрёт 12%
                        x(2) = Generate_nice_color
                    Loop While DictColor.Exists(x(2))
                    DictColor.Add cell.Value, 0
                End If
                x(3) = 2
                Dict.Item(cell.Value) = x
                Cells(x(0), x(1)).Interior.Color = x(2)
            End If
            cell.Interior.Color = x(2)
        Else
            s(0) = cell.Row
            s(1) = cell.Column
            s(3) = 1
            Dict.Add cell.Value, s
        End If
    Next
End If
Return
End Sub

Function Generate_nice_color() As Long
Dim R As Long, G As Long, B As Long
Do
    Randomize
    R = Int(Rnd * 256)
    G = Int(Rnd * 256)
    B = Int(Rnd * 256)
Loop Until R + G + B > 500 And R + G + B < 700
Generate_nice_color = RGB(R, G, B)
End Function
Изменено: bedvit - 27.02.2020 14:24:13
«Бритва Оккама» или «Принцип Калашникова»?
 
Теперь за 30 сек обрабатывается 50 млн. ячеек, с поиском 10 тыс. дубликатов.
«Бритва Оккама» или «Принцип Калашникова»?
 
Цитата
bedvit: Функция генерации приятных цветов
Функция создания не очень приятных, но визуально непохожих контрастных цветов
типа такой?  :)
Цитата
UPD: bedvit: 3,1 млн. цветов
нашёл твою функцию и посмотрел тему. А зачем тратить время на генерацию, если можно, как у меня создавать массив заранее вычисленных и подобранных цветов? Это ж мгновенно будет
Если не так понял, то скажи  :)
Изменено: Jack Famous - 12.08.2021 18:07:39
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
Jack Famous написал:
создавать массив заранее вычисленных и подобранных цветов
хранить все  3,1 млн. цветов? зачем? вычислить - это микросекунды.
«Бритва Оккама» или «Принцип Калашникова»?
 
Цитата
bedvit: вычислить - это микросекунды
тогда да - намного лучше
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Здравствуйте. Возможно ли отредактировать макрос bedvit из сообщений #17 так чтобы он выделял дубли одним цветом, а не разными. Если кто то сможет это сделать или покажет какую часть кода нужно удалить/изменить буду очень благодарен.
 
Заменить
Код
If i = 1 Then
                    x(2) = 6740479 ' мой первый :)
                Else
                    Do 'гарантия уникального цвета на группу дубликатов - жрёт 12%
                        x(2) = Generate_nice_color
                    Loop While DictColor.Exists(x(2))
                    DictColor.Add cell.Value, 0
                End If

На
Код
x(2) = 6740479
«Бритва Оккама» или «Принцип Калашникова»?
 
Огромное Вам спасибо
Страницы: 1
Наверх