Создать зависимость - заливка ячейки/данные ячейки? - Мир MS Excel

Регистрация

Напомнить пароль

= Мир MS Excel/Создать зависимость - заливка ячейки/данные ячейки? - Мир MS Excel

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Создать зависимость - заливка ячейки/данные ячейки? (Макросы/Sub)

Создать зависимость - заливка ячейки/данные ячейки?

Дата: Вторник, 26.07.2016, 12:17 | Сообщение № 1

Группа: Пользователи

Ранг: Участник

Сообщений: 63

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

Добрый день! Решаю задачу с условием: при выделении определенным цветом ячейки диапазона ХХ:ХХ листа "источник" данные из ячейки должны отобразиться на соответствующем листе каб№ХХ аналогичного диапазона, без заливки, только содержимое ячейки. Пример прилагается. Заливка из основной палитры цветов, оттенки не используются. Идея использовать макрос пока не дошла до завершения, пока только идея:) Прошу подсказок т.к. не знаток в этой области, спасибо! Работать будет в 10й версии пакета офис. Пример версии 2003

К сообщению приложен файл: ___.xls (31.5 Kb)

Ответить

Дата: Вторник, 26.07.2016, 13:06 | Сообщение № 2

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2566

Репутация: 724 ±

Замечаний: 0% ±

Excel 2010

Добрый день.
Для файла-примера вот такой код.
[vba]

Код

Sub qqq()
With Sheets("источник")
For c = 2 To 7
For r = 2 To 4

If .Cells(r, c).Interior.Color = 10498160 Then 'фиол каб1
Sheets("КАБ№1").Cells(r, c).Value = .Cells(r, c).Value
End If
If .Cells(r, c).Interior.Color = 15773696 Then 'голубой каб2
Sheets("КАБ№2").Cells(r, c).Value = .Cells(r, c).Value
End If
If .Cells(r, c).Interior.Color = 65535 Then 'желтый каб3
Sheets("КАБ№3").Cells(r, c).Value = .Cells(r, c).Value
End If
Next r
Next c
End With
End Sub

[/vba]

К сообщению приложен файл: 5565673.xlsm (22.6 Kb)

Яндекс: 410016850021169

Ответить

Дата: Вторник, 26.07.2016, 13:26 | Сообщение № 3

Группа: Пользователи

Ранг: Участник

Сообщений: 63

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

Спасибо большое! ТО что надо!

Ответить

Дата: Вторник, 26.07.2016, 15:20 | Сообщение № 4

Группа: Пользователи

Ранг: Участник

Сообщений: 63

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

sboy, за помощь спасибо! Есть недочет: данные "каб1,2,3" запоминаются и динамически не изменяются после последующего редактирования "источник"

К сообщению приложен файл: 7148675.xls (67.5 Kb)

Сообщение отредактировал NeWru - Вторник, 26.07.2016, 19:21

Ответить

Дата: Среда, 27.07.2016, 07:28 | Сообщение № 5

Группа: Пользователи

Ранг: Участник

Сообщений: 75

Репутация: 6 ±

Замечаний: 0% ±

Excel 2010

NeWru, ну вообще данные меняются после нажатия на кнопку "добавить данные в кабинете"

Ответить

Дата: Среда, 27.07.2016, 08:23 | Сообщение № 6

Группа: Пользователи

Ранг: Участник

Сообщений: 63

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

Kamikadze_N, выделите в источнике С3 желтым, нажмите добавить данные, затем выделите фиолетовым, добавить данные, затем снова желтым, добавить данные. Итог: в каб1 (фиолет) С3 не исчезнет. аналогично "запоминаются" старые данные в других каб. Приходится перед каждым редактированием источника "чистить" каб

Сообщение отредактировал NeWru - Среда, 27.07.2016, 08:25

Ответить

Дата: Среда, 27.07.2016, 08:34 | Сообщение № 7

Группа: Пользователи

Ранг: Участник

Сообщений: 75

Репутация: 6 ±

Замечаний: 0% ±

Excel 2010

NeWru, Добавьте в код проверку.
[vba]

Код

Sub qqq()
With Sheets("èñòî÷íèê")
For c = 2 To 7
For r = 2 To 4

If .Cells(r, c).Interior.Color = 10498160 Then 'ôèîë êàá1
Sheets("ÊÀÁ¹1").Cells(r, c).Value = .Cells(r, c).Value
End If
If .Cells(r, c).Interior.Color = 15773696 Then 'ãîëóáîé êàá2
Sheets("ÊÀÁ¹2").Cells(r, c).Value = .Cells(r, c).Value
End If
If .Cells(r, c).Interior.Color = 16777215 Then 'íåò öâåòà êàá3
Sheets("ÊÀÁ¹3").Cells(r, c).Value = .Cells(r, c).Value
End If
If .Cells(r, c).Interior.Color <> 10498160 And .Cells(r, c).Interior.Color <> 15773696 And _
.Cells(r, c).Interior.Color <> 16777215 Then
Sheets("ÊÀÁ¹1").Cells(r, c).Value = .Cells(1, 1).Value
Sheets("ÊÀÁ¹2").Cells(r, c).Value = .Cells(1, 1).Value
Sheets("ÊÀÁ¹3").Cells(r, c).Value = .Cells(1, 1).Value
End If
Next r
Next c
End With
End Sub

[/vba]

К сообщению приложен файл: 7148675-1-.xlsm (27.0 Kb)

Сообщение отредактировал Kamikadze_N - Среда, 27.07.2016, 08:36

Ответить

Дата: Среда, 27.07.2016, 09:02 | Сообщение № 8

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2566

Репутация: 724 ±

Замечаний: 0% ±

Excel 2010

NeWru, или можно сделать очистку на отдельную кнопку
[vba]

Код

Sub Clear()
Sheets("КАБ№1").Range("B2:G4").ClearContents
Sheets("КАБ№2").Range("B2:G4").ClearContents
Sheets("КАБ№3").Range("B2:G4").ClearContents
End Sub

[/vba]

К сообщению приложен файл: 7168651.xlsm (23.6 Kb)

Яндекс: 410016850021169

Ответить

Дата: Среда, 27.07.2016, 11:59 | Сообщение № 9

Группа: Пользователи

Ранг: Участник

Сообщений: 63

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

Kamikadze_N, вот спасибо! Об этом я и говорил, теперь правильно! А если таблица кабХХ в другом диапазоне будет, например ниже на строку и правее на столбец, то в макрос добавятся новые переменные к имеющимся "r" и "с" чтобы не съехали данные ?

Ответить

Дата: Среда, 27.07.2016, 12:00 | Сообщение № 10

Группа: Пользователи

Ранг: Участник

Сообщений: 63

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

sboy, спасибо!

Ответить

Дата: Среда, 27.07.2016, 12:57 | Сообщение № 11

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2566

Репутация: 724 ±

Замечаний: 0% ±

Excel 2010

Цитата sboy, 27.07.2016 в 09:02, в сообщении № 8

ниже на строку и правее на столбец

[vba]

Код

...
For c = 2 To 7 'перебираем столбцы со 2 по 7
For r = 2 To 4 'перебираем строки со 2 по 4
...

[/vba]
соответственно увеличивая вторые цифры в циклах (7 и 4), увеличиваем размер обрабатываемой таблицы данных.

Яндекс: 410016850021169

Ответить

Дата: Среда, 27.07.2016, 13:03 | Сообщение № 12

Группа: Пользователи

Ранг: Участник

Сообщений: 63

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

sboy, ок, разобрался! Спасибо за подробную помощь!

Ответить

Дата: Среда, 27.07.2016, 13:42 | Сообщение № 13

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2731

Репутация: 1132 ±

Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1

Чиста не мог пройти мимо со своим косметическим перфекционизмом:
[vba]

Код

Sub qqq()
    Dim sheetName As String
    With Sheets("источник")
    For c = 2 To 7
        For r = 2 To 4
            Select Case .Cells(r, c).Interior.Color
                Case RGB(112, 48, 160)  '=10498160 'фиол каб1
                    sheetName = "КАБ№1"
                Case RGB(0, 176, 240)   '=15773696 'голубой каб2
                    sheetName = "КАБ№2"
                Case RGB(255, 255, 255) '=16777215 'нет цвета каб3
                    sheetName = "КАБ№3"
                Case Else
                    sheetName = ""
            End Select
            If sheetName <> "" Then
                Sheets(sheetName).Cells(r, c).Value = .Cells(r, c).Value
            Else
                Sheets("КАБ№1").Cells(r, c).ClearContents
                Sheets("КАБ№2").Cells(r, c).ClearContents
                Sheets("КАБ№3").Cells(r, c).ClearContents
            End If
        Next r
    Next c
    End With
End Sub

[/vba]
P.S. Чтобы не пугать друг друга страшенными восьмизначными числами цветов, заменим их вызовами функции RGB. Ее параметры в каждом конкретном случае можно узнать, вызвав на ячейке с нужным цветом окно заливки "Цвет заливки \ Другие цвета \ Спектр" и прочитав значения в полях "Красный", "Зеленый", "Синий" (при этом в поле "Цветовая модель" должно быть указано "RGB").

Чиста не мог пройти мимо со своим косметическим перфекционизмом:
[vba]

Код

Sub qqq()
    Dim sheetName As String
    With Sheets("источник")
    For c = 2 To 7
        For r = 2 To 4
            Select Case .Cells(r, c).Interior.Color
                Case RGB(112, 48, 160)  '=10498160 'фиол каб1
                    sheetName = "КАБ№1"
                Case RGB(0, 176, 240)   '=15773696 'голубой каб2
                    sheetName = "КАБ№2"
                Case RGB(255, 255, 255) '=16777215 'нет цвета каб3
                    sheetName = "КАБ№3"
                Case Else
                    sheetName = ""
            End Select
            If sheetName <> "" Then
                Sheets(sheetName).Cells(r, c).Value = .Cells(r, c).Value
            Else
                Sheets("КАБ№1").Cells(r, c).ClearContents
                Sheets("КАБ№2").Cells(r, c).ClearContents
                Sheets("КАБ№3").Cells(r, c).ClearContents
            End If
        Next r
    Next c
    End With
End Sub

[/vba]
P.S. Чтобы не пугать друг друга страшенными восьмизначными числами цветов, заменим их вызовами функции RGB. Ее параметры в каждом конкретном случае можно узнать, вызвав на ячейке с нужным цветом окно заливки "Цвет заливки \ Другие цвета \ Спектр" и прочитав значения в полях "Красный", "Зеленый", "Синий" (при этом в поле "Цветовая модель" должно быть указано "RGB").Gustav

МОИ: Ник, Tip box: 41001663842605

Сообщение отредактировал Gustav - Среда, 27.07.2016, 14:22

Ответить

СообщениеЧиста не мог пройти мимо со своим косметическим перфекционизмом:
[vba]

Код

Sub qqq()
    Dim sheetName As String
    With Sheets("источник")
    For c = 2 To 7
        For r = 2 To 4
            Select Case .Cells(r, c).Interior.Color
                Case RGB(112, 48, 160)  '=10498160 'фиол каб1
                    sheetName = "КАБ№1"
                Case RGB(0, 176, 240)   '=15773696 'голубой каб2
                    sheetName = "КАБ№2"
                Case RGB(255, 255, 255) '=16777215 'нет цвета каб3
                    sheetName = "КАБ№3"
                Case Else
                    sheetName = ""
            End Select
            If sheetName <> "" Then
                Sheets(sheetName).Cells(r, c).Value = .Cells(r, c).Value
            Else
                Sheets("КАБ№1").Cells(r, c).ClearContents
                Sheets("КАБ№2").Cells(r, c).ClearContents
                Sheets("КАБ№3").Cells(r, c).ClearContents
            End If
        Next r
    Next c
    End With
End Sub

[/vba]
P.S. Чтобы не пугать друг друга страшенными восьмизначными числами цветов, заменим их вызовами функции RGB. Ее параметры в каждом конкретном случае можно узнать, вызвав на ячейке с нужным цветом окно заливки "Цвет заливки \ Другие цвета \ Спектр" и прочитав значения в полях "Красный", "Зеленый", "Синий" (при этом в поле "Цветовая модель" должно быть указано "RGB").

Автор - Gustav
Дата добавления - 27.07.2016 в 13:42

Дата: Среда, 27.07.2016, 14:01 | Сообщение № 14

Группа: Пользователи

Ранг: Участник

Сообщений: 63

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

Gustav, и вам спасибо!

Ответить

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Создать зависимость - заливка ячейки/данные ячейки? (Макросы/Sub)

Страница 1 из 1
1

© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!