Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

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

 

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

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Создать зависимость - заливка ячейки/данные ячейки? (Макросы/Sub)
Создать зависимость - заливка ячейки/данные ячейки?
NeWru Дата: Вторник, 26.07.2016, 12:17 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 46
Репутация: 0 ±
Замечаний: 0% ±

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

Автор - NeWru
Дата добавления - 26.07.2016 в 12:17
sboy Дата: Вторник, 26.07.2016, 13:06 | Сообщение № 2
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 196
Репутация: 48 ±
Замечаний: 0% ±

Excel 2007
Добрый день.
Для файла-примера вот такой код.
[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(23Kb)
 
Ответить
СообщениеДобрый день.
Для файла-примера вот такой код.
[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]

Автор - sboy
Дата добавления - 26.07.2016 в 13:06
NeWru Дата: Вторник, 26.07.2016, 13:26 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 46
Репутация: 0 ±
Замечаний: 0% ±

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

Автор - NeWru
Дата добавления - 26.07.2016 в 13:26
NeWru Дата: Вторник, 26.07.2016, 15:20 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 46
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
sboy, за помощь спасибо! Есть недочет: данные "каб1,2,3" запоминаются и динамически не изменяются после последующего редактирования "источник"
К сообщению приложен файл: 7148675.xls(68Kb)


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

Автор - NeWru
Дата добавления - 26.07.2016 в 15:20
Kamikadze_N Дата: Среда, 27.07.2016, 07:28 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 42
Репутация: 5 ±
Замечаний: 0% ±

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

Автор - Kamikadze_N
Дата добавления - 27.07.2016 в 07:28
NeWru Дата: Среда, 27.07.2016, 08:23 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 46
Репутация: 0 ±
Замечаний: 0% ±

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


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

Автор - NeWru
Дата добавления - 27.07.2016 в 08:23
Kamikadze_N Дата: Среда, 27.07.2016, 08:34 | Сообщение № 7
Группа: Пользователи
Ранг: Новичок
Сообщений: 42
Репутация: 5 ±
Замечаний: 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(27Kb)


Сообщение отредактировал Kamikadze_N - Среда, 27.07.2016, 08:36
 
Ответить
Сообщение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]

Автор - Kamikadze_N
Дата добавления - 27.07.2016 в 08:34
sboy Дата: Среда, 27.07.2016, 09:02 | Сообщение № 8
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 196
Репутация: 48 ±
Замечаний: 0% ±

Excel 2007
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(24Kb)
 
Ответить
Сообщение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]

Автор - sboy
Дата добавления - 27.07.2016 в 09:02
NeWru Дата: Среда, 27.07.2016, 11:59 | Сообщение № 9
Группа: Пользователи
Ранг: Новичок
Сообщений: 46
Репутация: 0 ±
Замечаний: 0% ±

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

Автор - NeWru
Дата добавления - 27.07.2016 в 11:59
NeWru Дата: Среда, 27.07.2016, 12:00 | Сообщение № 10
Группа: Пользователи
Ранг: Новичок
Сообщений: 46
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
sboy, спасибо!
 
Ответить
Сообщениеsboy, спасибо!

Автор - NeWru
Дата добавления - 27.07.2016 в 12:00
sboy Дата: Среда, 27.07.2016, 12:57 | Сообщение № 11
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 196
Репутация: 48 ±
Замечаний: 0% ±

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

[vba]
Код

...
For c = 2 To 7 'перебираем столбцы со 2 по 7
For r = 2 To 4 'перебираем строки со 2 по 4
...
[/vba]
соответственно увеличивая вторые цифры в циклах (7 и 4), увеличиваем размер обрабатываемой таблицы данных.
 
Ответить
Сообщение
ниже на строку и правее на столбец

[vba]
Код

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

Автор - sboy
Дата добавления - 27.07.2016 в 12:57
NeWru Дата: Среда, 27.07.2016, 13:03 | Сообщение № 12
Группа: Пользователи
Ранг: Новичок
Сообщений: 46
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
sboy, ок, разобрался! Спасибо за подробную помощь!
 
Ответить
Сообщениеsboy, ок, разобрался! Спасибо за подробную помощь!

Автор - NeWru
Дата добавления - 27.07.2016 в 13:03
Gustav Дата: Среда, 27.07.2016, 13:42 | Сообщение № 13
Группа: Друзья
Ранг: Старожил
Сообщений: 1211
Репутация: 484 ±
Замечаний: 0% ±

начинал с Excel 4.0...
Чиста не мог пройти мимо со своим косметическим перфекционизмом:
[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").


Мой 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
NeWru Дата: Среда, 27.07.2016, 14:01 | Сообщение № 14
Группа: Пользователи
Ранг: Новичок
Сообщений: 46
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Gustav, и вам спасибо!
 
Ответить
СообщениеGustav, и вам спасибо!

Автор - NeWru
Дата добавления - 27.07.2016 в 14:01
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Создать зависимость - заливка ячейки/данные ячейки? (Макросы/Sub)
Страница 1 из 11
Поиск:

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