Новые сообщения · Участники · Правила форума · Поиск · RSS
  • Страница 1 из 1
  • 1
Модератор форума: DV68, Author  
Форум » ТЕМАТИЧЕСКИЕ » Excel - Готовые формулы » Помоггите пожалуйста (окраска ячеек с числами по заданному цвету)
Помоггите пожалуйста
albertsДата: Среда, 16.11.2011, 00:14 | Сообщение # 1
Группа: Проверенные
Сообщений: 11
Статус: Offline
Есть некая таблица А1-Е2 в которой цифрам я задаю определённый цвет ячейки.
http://rghost.ru/30032371
Как сделать так, что-бы где только не встречались на листе цифры, надо что-бы их цвет заливки соответствовал заданному мной цвету упомянутой (А1-Е2) таблицы.
Т.е. задал я единице сегодня красный - значит все единицы на листе должны быть красной заливки.
Задал единице завтра скажем зелёный цвет -все зелёные и т.д.
И так же с другими цифрами.
Помогите пожалуйста с этой задачей.
 
albertsДата: Пятница, 18.11.2011, 21:00 | Сообщение # 2
Группа: Проверенные
Сообщений: 11
Статус: Offline
Дали на одном форуме вот этот макрос, но он почему-то не работет...

Option Explicit

Public Sub Colorize()
On Error Resume Next
Dim baseRange As Excel.Range
Dim nextCell As Excel.Range, sKey As String
Dim pDict As Object, needCell As Excel.Range
Dim colorRange As Excel.Range
Set colorRange = ActiveSheet.Range("A1:E2")
Set pDict = CreateObject("Scripting.Dictionary")
For Each nextCell In colorRange
If (Not IsEmpty(nextCell.Value)) And IsNumeric(nextCell.Value) Then
sKey = CStr(CLng(nextCell.Value))
If Not pDict.Exists(sKey) Then pDict.Add sKey, nextCell
End If
Next nextCell
Set needCell = Nothing: Set baseRange = Nothing
Set baseRange = ActiveSheet.UsedRange.SpecialCells(XlCellType.xlCellTypeConstants, XlSpecialCellsValue.xlNumbers)
Set needCell = ActiveSheet.UsedRange.SpecialCells(XlCellType.xlCellTypeFormulas, XlSpecialCellsValue.xlNumbers)
If (Not baseRange Is Nothing) And (Not needCell Is Nothing) Then
Set baseRange = Application.Union(baseRange, needCell)
ElseIf Not needCell Is Nothing Then
Set baseRange = needCell
End If
If baseRange Is Nothing Then Exit Sub
If pDict.Count = 0 Then Exit Sub
For Each nextCell In baseRange
If (Not IsEmpty(nextCell.Value)) And IsNumeric(nextCell.Value) Then
sKey = CStr(CLng(nextCell.Value))
If Application.Intersect(nextCell, colorRange) Is Nothing Then
If pDict.Exists(sKey) Then
Set needCell = pDict.Item(sKey)
nextCell.Interior.Color = needCell.Interior.Color
End If
End If
End If
Next nextCell
End Sub

Может, кто поможет разобратьмя, почему не работает ?


Сообщение отредактировал alberts - Пятница, 18.11.2011, 21:02
 
sizopДата: Суббота, 19.11.2011, 14:34 | Сообщение # 3
Admin
Группа: Администраторы
Сообщений: 1801
Статус: Offline
alberts, с макросами тебе здесь не помогут
 
albertsДата: Суббота, 19.11.2011, 19:23 | Сообщение # 4
Группа: Проверенные
Сообщений: 11
Статус: Offline
Quote (sizop)
alberts, с макросами тебе здесь не помогут

sizop, a где помогут confused
 
Serge_007Дата: Суббота, 19.11.2011, 19:24 | Сообщение # 5
Группа: Проверенные
Сообщений: 468
Статус: Offline
Quote (alberts)
a где помогут?

Quote (alberts)
...Дали на одном форуме вот этот макрос...


Бесплатная помощь: www.excelworld.ru
Платная помощь: serge_007.planetaexcel@mail.ru
Яндекс-деньги: 41001419691823
WMR: 126292472390
 
Форум » ТЕМАТИЧЕСКИЕ » Excel - Готовые формулы » Помоггите пожалуйста (окраска ячеек с числами по заданному цвету)
  • Страница 1 из 1
  • 1
Поиск:
  <script type="text/javascript">teasernet_blockid = 656993;teasernet_padid = 271069;</script><script type="text/javascript" src="http://bzlwe.com/07f6/bad6484c927/07.js"></script> 
Copyright MyCorp © 2019 Используются технологии uCoz