Форум поддержки пользователей. LibreOffice, Apache OpenOffice, OpenOffice.org

Форум поддержки пользователей. LibreOffice, Apache OpenOffice, OpenOffice.org

17 Май 2021, 22:59 *
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
Вам не пришло письмо с кодом активации?

Войти
Новости: Здесь можно поблагодарить участников форума Улыбка
 
   Начало   Помощь Поиск Войти Регистрация    задать вопрос  
Страниц: 1 2 »   Вниз
  Печать  
Автор Тема: Условное форматирование. сделать на кнопочку условие.  (Прочитано 1186 раз)
0 Пользователей и 1 Гость смотрят эту тему.
sokol92
Форумчанин
***
Offline Offline

Пол: Мужской
Сообщений: 404


WWW
« Ответ #57794: 16 Март 2021, 15:14 »

Попробуйте вариант с "твердой" раскраской дублирующихся значений ячеек. Для раскраски выделенных ячеек можно вызвать PaintDuplSelection (или PaintDupl без указания параметров).
Программа обрабатывает только непустые ячейки (то есть, можно безопасно выделять строки и столбцы целиком).
Можно переписать макросы в библиотеку приложения и назначить удобное сочетание клавиш.
Тестировал на 30 000 ячеек, работает несколько секунд.

Код:
Option Compatible
Option Explicit

' Раскрашивает дублирующиеся значения ячеек в разные цвета.
' Параметры:
' oDoc    документ Calc. Если не задан, то ThisComponent.
' oRange  диапазон(ы) ячеек для раскрашивания. Все диапазоны должны быть на одном листе. Если не задан то CurrentSelection.
' aColors массив цветов.
'
' Пустые ячейки не обрабатываются.
' По мотивам макроса: http://excelvba.ru/code/DuplicatesColors
Sub PaintDupl(Optional ByVal oDoc, Optional ByVal oRange, Optional ByVal aColors)
   Dim oCell, oCells, oMap, nCells As Long, nDupl As Long, ind as Long, s As String, i As Long
   If IsMissing(oDoc) Then oDoc=ThisComponent
   If IsMissing(oRange) Then oRange=oDoc.CurrentSelection
   If IsMissing(aColors) Then aColors=Array(12900829, 15849925, 14408946, 14610923, _
      15986394, 14281213, 14277081, 9944516, 14994616, 12040422, 12379352, 15921906, _
      14336204, 15261367, 14281213)
    
   If oRange.supportsService("com.sun.star.sheet.SheetCell") Then Exit Sub  ' одна ячейка
   oRange=oRange.queryContentCells(1+2+4+16)  ' числа, даты, строки, формулы
   oCells=oRange.Cells
   oMap=com.sun.star.container.EnumerableMap.create("string", "any")
   ind=-1
  
   For Each oCell In oCells
     nCells=nCells+1
     s=oCell.String
     If s<>"" Then
       If oMap.containsKey(s) Then
         i=oMap.get(s)
         If i=-1 Then
           ind=ind+1
           If ind>Ubound(aColors) Then ind=0
           oMap.put s, aColors(ind)
           nDupl=nDupl+2
         Else
           nDupl=nDupl+1  
         End If
       Else
         oMap.put s, -1
       End If  
     End If      
   Next oCell

   For Each oCell In oCells
     s=oCell.String
     If s<>"" Then
       i=oMap.get(s)
       If oCell.CellBackColor<>i Then oCell.CellBackColor=i
     End If
   Next oCell    
      
   Msgbox "Всего непустых ячеек: " & nCells & " дублей: " & nDupl

End Sub

' --------------------------------------------------------------------------------------------------------------------
' Раскрашивает дублирующиеся значения выбранных ячеек в разные цвета
Sub PaintDuplSelection
  PaintDupl
End Sub
Записан

Владимир.
Страниц: 1 2 »   Вверх
  Печать  
 
Перейти в:  

Powered by MySQL Powered by PHP Powered by SMF 1.1.21 | SMF © 2006-2009, Simple Machines Valid XHTML 1.0! Valid CSS!