Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Копирование содержимого листа с разбивкой цветов фона на компоненты (RGB)
 
Хочу создать свой Календарь-Планнинг с возможностью последующего контроля.

Например:

На первом листе:
Первая колонка - время
Первая строка - даты
Внутри таблицы есть мероприятия, ячейки которых залиты определённым цветом, соответствующим определённой сфере.

На втором листе:
Хочу, чтобы при помощи определённого макроса создавалась копия первого листа, но чтобы каждая ячейка была уже представлена в виде значений RGB через ";"


Если это возможно, то выглядеть это должно следующим образом:
(Прикреплён файл)
 
Цитата
andreyglad-48 написал: Хочу создать...Хочу, чтобы...
А вопрос-то в чем? Что не получается?
Согласие есть продукт при полном непротивлении сторон.
 
Не умею написать такой макрос
 
Т.е. все за Вас и с нуля?
Согласие есть продукт при полном непротивлении сторон.
 
Вот месяц назад нашёл такое решение:
Код
Option Explicit
Public Const C_RGB_RED As Long = &HFF&
Public Const C_RGB_GREEN As Long = &HFF00&
Public Const C_RGB_BLUE As Long = &HFF0000
Public Const C_RGB_WHITE As Long = &HFFFFFF
Public Const C_RGB_BLACK As Long = &H0&
Public Const C_MIN_COLOR_INDEX = 1
Public Const C_MAX_COLOR_INDEX = 56
Public Const C_MIN_RGB = C_RGB_BLACK
Public Const C_MAX_RGB = C_RGB_WHITE
Public Const C_SHIFT_ONE_BYTE = &H100&
Public Const C_SHIFT_TWO_BYTES = &H10000

Sub RGBColor()
'Взято с сайта http://www.cpearson.com/excel/colors.aspx
 Dim RGBColor As Long
    Dim Red As Long
    Dim Green As Long
    Dim Blue As Long
    Dim B As Boolean
    
    RGBColor = ActiveCell.Interior.Color
    B = RGBComponentsFromRGBLongToVariables(RGBColor, Red, Green, Blue)
    If B = True Then
        'Debug.Print "Red: " & Red, "Blue: " & Blue, "Green: " & Green
        With ActiveCell
            .Offset(0, 1) = Red
            .Offset(0, 2) = Green
            .Offset(0, 3) = Blue
        End With
    Else
        ActiveCell.Offset(0, 1) = "Неверный цвет RGB"
        'Debug.Print "Invalid value in RGBColor"
    End If
End Sub

Private Function RGBComponentsFromRGBLongToVariables(RGBLong As Long, _
    ByRef Red As Long, ByRef Green As Long, ByRef Blue As Long) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' RGBComponentsFromRGBLongToVariables
' This set the variables references Red, Green, and Blue to
' the component colors of the RGBLong color. It returns
' True if RGBLong is a valid color (between &H00000000 and
' &H00FFFFFF) or False if RGBLong is not a valid RGB color.
' If RGBLong is invalid, the component variables are set to -1.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Arr As Variant
    If IsValidRGBLong(RGBLong) = True Then
        Arr = RGBComponentsFromRGBLong(RGBLong)
        Red = Arr(1)
        Green = Arr(2)
        Blue = Arr(3)
        RGBComponentsFromRGBLongToVariables = True
    Else
        Red = -1
        Green = -1
        Blue = -1
        RGBComponentsFromRGBLongToVariables = False
    End If
End Function

Private Function IsValidRGBLong(RGBLong As Long) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' IsValidRGBLong
' This returns True if RGBLong is between &H00000000 and
' &H00FFFFFF or False otherwise.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If (RGBLong >= C_MIN_RGB) And (RGBLong <= C_MAX_RGB) Then
        IsValidRGBLong = True
    Else
        IsValidRGBLong = False
    End If
End Function

Private Function RGBComponentsFromRGBLong(RGBLong As Long) As Long()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' RGBComponentsFromRGBLong
' This accepts an RGBLong and returns a 1-based array with
' three elements, containing, left-to-right, the Red, Green,
' and Blue components of the RGB Color. If RGBLong is not
' a valid RGB color, all elements of the returned array
' are -1.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim Arr(1 To 3) As Long
    If IsValidRGBLong(RGBLong:=RGBLong) = False Then
        Arr(1) = -1
        Arr(2) = -1
        Arr(3) = -1
        Exit Function
    End If
    Arr(1) = RGBLong And C_RGB_RED
    Arr(2) = (RGBLong And C_RGB_GREEN) \ C_SHIFT_ONE_BYTE ' shift right 1 byte
    Arr(3) = (RGBLong And C_RGB_BLUE) \ C_SHIFT_TWO_BYTES ' shift right 2 bytes
    RGBComponentsFromRGBLong = Arr
End Function


Единственное, что нужно изменить, так это чтобы значения можно было результировать не рядом а на соседний лист в виде не трёх а одного значения через ";"
 
Если данная помощь требует оплаты, то прошу перенести в ветку "работа". На усмотрение модератора, доверяю, поскольку ему виднее.
 
И если есть такой человек из Липецка, Воронежа или Москвы, то рад бы обращаться к нему за помощью воочию, чтобы не иметь сложностей в письменном объяснении. Буду рад если такие есть. Или подскажите, пожалуйста как их найти.
 
Это Вам виднее, в задачу не вникал. Переносить?
 
По идее цветовой индекс (значение) формируется из трех байтов RGB, если порядок байтов (старшинство) остается такое-же, то раскидать по цветам не проблема.
Во вложении функция по разбивке цветового кода на цвета с примером ее применения. При написании исходил из предположения, что:
- RED - старший байт из трех
- GREEN - средний
- BLUE - младший
----upd----
как выяснилось порядок старшинства байтов обратный (BGR)
Изменено: Anchoret - 9 Мар 2018 04:28:50
 
Конкретно для данной задачи:
Код
Sub CopySheet()
Dim Ash As Worksheet, Bsh As Worksheet
Dim R1 As Range, R2 As Range, R3 As Range, aa As Range, bb As Range
Application.ScreenUpdating = False
Set Ash = Sheets(1): Set Bsh = Sheets(2)
Bsh.Cells.Clear: Ash.Cells.Copy Bsh.[A1]
Application.CutCopyMode = False
Set R1 = [B5:AF18]
Set R2 = [E22:AH45]
Set R3 = [H49:AL61]
Set aa = Union(R1, R2, R3)
For Each bb In aa
  bb.Value = ToRGB(bb.Interior.Color)
Next
Application.ScreenUpdating = True
End Sub

Function ToRGB$(ByVal iColor&)
Dim red&, green&, blue&
Const constB = 16711680
Const constG = 65280
Const constR = 255
red = iColor Or (constB + constG) Xor (constB + constG)
green = (iColor Or (constB + constR) Xor (constB + constR)) / 256
blue = (iColor Or (constG + constR) Xor (constG + constR)) / 256 / 256
ToRGB = red & ";" & green & ";" & blue
End Function

Вариант названия темы: Копирование содержимого листа с разбивкой цветов фона на компоненты (RGB)

Изменено: Anchoret - 9 Мар 2018 11:25:10
 
Ого! Вы волшебник. То, что нужно! Как я могу отблагодарить Вас?
 
Ой. А при добавлении ещё одного месяца, макрос копирует цвет, но не расшифровывает его в виде значений RGB...

Можно ли сделать так, чтобы он при наличии заливки в любой ячейке листа - копировал также и его значение RGB?
 
А насчёт темы, не знаю как её изменить. В заголовке вроде правильно написано. Просто изначально я думал, чтобы в каждую ячейку соседнего листа копировались:
R;G;B;Содержимое ячейки (которое на первом листе, которое тоже хочу писать в виде параметров \например: Подкатегория сферы;КПД;Оценка\)
чтобы потом по какой-нибудь формуле и условию в следующем листе контролировать результат.

Например:
ЕСЛИ в этом месяце по этой дате есть Сфера (значение RGB), то извлечь из этой ячейки 4-й аругумент после ";"
ЕСЛИ в этом месяце по этой дате есть Сфера (значение RGB), то извлечь из этой ячейки 5-й аругумент после ";"

Но поскольку это очень сложно объяснить, что я хочу, я удалил эту тему и информацию. (Обновил страницу)

Мне показалось, что проще просто, вообще, скопировать все данные в виде RGB, а дальше я бы сам смог играться с ними как мне удобно "ЕСЛИ" в таком то диапазоне есть такое значение RGB, "ТО" из первого листа соответствующей ячейки изъять третий аргумент после разделителя.

Как извлекать эту конкретную информацию из этого общего значения, я пока что ещё не знаю.  Может быть подскажете, как это можно сделать.
Но это я думаю более простая задача, макрос не нужен, поэтому не стал писать всё это сюда.
Изменено: andreyglad-48 - 9 Мар 2018 10:55:48 (Форматировал сообщение, чтобы было более читаемым)
 
andreyglad-48, так ячейка без заливки тоже имеет цвет.
В общем макрос ищет все области напротив не нулевых значений в столбце "А" и далее вправо.
Код:
Скрытый текст
Изменено: Anchoret - 9 Мар 2018 11:37:29
 
Не получилось. Я ниже добавляю ещё один и ещё один месяцы и макрос копирует только, а значения RGB цвета почему-то не пишет в новые месяцы.
Макрос работает только для определённого диапазона?
А потом, когда я добавил свой личный календарь (12 месяцев) он вообще выдал такое сообщение: (на картинке)

А возможно ли, чтобы я сам указывал (выделением диапазона) с какой областью должен работать макрос и генерировать их значения RGB?

??? Подскажите пожалуйста, смогу ли я потом, без помощи макроса, по условию аргумента RGB вычленять (извлекать) оттуда определённые аргументы (второй-третий аргумент) которые там есть, в ячейке, заданные через ";".

1. Если это возможно, тогда я прошу помочь в том, чтобы макрос делал так:

Если в ячейке нет заливки цветом, то RGB значение не нужно (только её содержимое). А если есть цвет, то RGB+её содержимое через разделитель ";" (R;G;B;Содержимое ячейки)
Таким образом, если в ячейке нет цвета, будет только содержимое.
А если есть цвет, то: R;G;B;Содержимое

2. А если это невозможно, тогда я могу вручную скопировать то, что мне нужно (время, даты) на второй лист. А макрос пусть копирует туда только то, что я выделю диапазоном.

3. Если вы не знаете, как можно извлечь аргументы из ячейки (представленные в виде "R;G;B;4;5;6;7;8;9;n"), тогда меня вполне устроит, чтобы макрос копировал только R;G;B аргументы)

4. !!! Три разных макроса (три кнопки) для выделенного диапазона:
  1. Для копирования только Cодержимого как есть
  2. Для генерирования значений только R;G;B ячейки
  3. Для генерирования всех значений R;G;B;Содержимого
Последний, конечно, был бы идеальным вариантом.

Так, мне кажется, макрос работать быстрее будет. Выделил определённый диапазон он его и сгенерировал, и старое осталось, предыдущие месяцы, чтобы их заново каждый раз не генерировать.
Изменено: andreyglad-48 - 9 Мар 2018 15:09:15
 
andreyglad-48, не знаю что Вы там делали с файлом/кодом. Накопипастил еще несколько "месяцев", итого их уже 16 - макрос отработал все 16, ошибок нет. Структура файла менялась?
Вот последний вариант:
- Вариант 1 - все, как прежде
- Вариант 2 - прописываем RGB + значение ячейки через ";" по всем закрашенным ячейкам листа
Изменено: Anchoret - 9 Мар 2018 17:06:16
 
Да, структура будет меняться. Добавил строку, удалил строку. Добавил столбец.
 
Да, заработало и для 12 месяцев и с добавлением строк и столбцов. Но макрос ОЧЕНЬ долго выполняется. Несколько минут на моём ноутбуке.

Можно ли сделать эти же 2 кнопочки, но чтобы макрос выполнялся только для выделенного диапазона?
А то, получается, чтобы сгенерировать один день, макрос весь год заново перезаписывает данные.
Т.е. январь, февраль я уже отработал, проанализировл, поэтому они остаются без изменений - зачем так грузить макрос перезаписыванием того, что уже есть..
А вот с мартом я работаю, поэтому буду каждый день анализировать его. Всего один-два столбца в одном месяце, но часто, ежедневно. Тогда мне кажется макрос обновлял бы данные всего за секунду.

Если это невозможно или слишком сложно, я смирюсь и буду счастлив тому что уже есть.  :)
Изменено: andreyglad-48 - 10 Мар 2018 12:42:20
 
Он и до этого работал. Не надо только убивать строки с числами месяца... На моем не самом быстром компе выполнение занимает менее секунды. Значит у Вас там в основном файле много многоэтажных формул. Почитайте про отключение пересчета формул на время выполнения макроса и как это добавить макрос. Все это время я неоднократно переписывал код под Ваши хотелки, которые постоянно меняются. Теперь сами или ждите помощь от кого-то другого.
 
Спасибо Вам огромное, за то что помогли мне и подсказали, что проблема в пересчёте формул. Я счастлив, что есть такой форум и такие добрые люди, как Вы!
 
andreyglad-48, и Вам удачи в поисках ответов на Ваши вопросы.
 
Anchoret, переместите меня пожалуйста в платную ветку и помогите мне доделать календарь.
 
andreyglad-48, я такому не обучен) Т.е. это к модераторам.
 
Как мне с вами связаться?
 
andreyglad-48, напишите сообщение в личку - в чём проблема?
 
Anchoret, я вам написал в личку
 
Обсуждаем.
 
1. Мне нужно, чтобы ячейки каждого дня моего календаря скопировались в соседний лист не в том же прямоугольном виде, а в один столбец по возрастанию даты, времени.
Получится, что в этом столбце в каждой ячейке находятся данные через ";"

2. Я хочу чтобы эти данные "разделились" по ячейкам

3. Для чего мне это нужно:

Хочу ставить цель, например, читать книгу каждый день по 20 страниц ";" за наименьшее количество времени.
Бегать на пробежку на "максимальное расстояние" ; " за "минимальное время"
Получается, например, я запланировал пробежать 10 км за 1 час. В ячейку календаря я запланировал это мероприятие, выделил определённым цветом присвоенным этому мероприятию и по прошествию мероприятия ставлю оценку через ";". Например: "Пробежка;10;45"
На третьем листе я создал таблицу, где есть строка "пробежка;км" и строка для параметра "мин"

При определённых манипуляциях без макроса я смогу сам задать формулу для поиска этих данных из таблицы, чтобы видеть достижения, строить графики.

Образец результата прикрепляю:
(кнопка макроса на 2 листе "вариант 1" уже не актуальна. Второй вариант - что нужно)

Прошу сказать, сколько это будет стоить руб,
чтобы макрос выстроил календарь в столбец и разделил данные по ячейкам вправо (условие для разделения - ";" внутри ячейки)
Изменено: andreyglad-48 - 17 Апр 2018 22:37:16
 
Ответил в ЛС.
-------------
Сделано.
Оплачено.
Изменено: Anchoret - 19 Апр 2018 09:29:14
 
на 120%, спасибо!
Страницы: 1
Читают тему (гостей: 2)
Наверх