VBA копирование диапазона: только значение и цвет (исключая всякое иное форматирование) / Visual Basic

Мобильная версия Контакт Правила FAQ Помощь

Гость

Войти | Регистрация | Профиль | Очистить

Форумы | Пользователи | Статистика | Мод. лог | Поиск

Доб. в избранное | Игнор. тему | Прикреп. тему | Пометить прочит. / непрочит. | Фильтр

Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / VBA копирование диапазона: только значение и цвет (исключая всякое иное форматирование)

17 сообщений из 17, страница 1 из 1

VBA копирование диапазона: только значение и цвет (исключая всякое иное форматирование)

#39580797

ВладимирГК

Гость

Здравствуйте уважаемые и продвинутые в VBA товарищи!
До сих пор с удовольствием пользовался ресурсами форума как сторонний наблюдатель - без регистрации, так сказать.
Но вот наступил момент, когда найти ответ на свой вопрос не могу, а решать задачу необходимо.
Пожалуйста, подскажите как написать код макроса, который копировал бы определённый диапазон ячеек в одном листе и вставлял скопированные значения в другой лист. При вставке необходимо вставлять только значения (использую Selection.PasteSpecial Paste:=xlPasteValues) и, что оказалось неподъемным - ТОЛЬКО ЦВЕТ ЯЧЕЕК! Paste:=xlPasteFormats для меня не подходит, т.к. вставляются все форматы, включая условное форматирование, шрифт и прочее. А нужно - только цвет ячеек! Где-то читал об использовании циклов, но этот вариант также не очень желателен, т.к. диапазонов много (40-50) и значений в каждом диапазоне может быть от 20 до 500 строк.
Очень надеюсь, что есть решение данной проблемы. Не проходите мимо!!!
P.S. Оцениваю свой уровень знания VBA как начинающий, поэтому прошу по возможности комментировать строки кода, чтобы я мог понять их смысл.

...

Рейтинг:

0 / 0

09.01.2018, 06:20

| Ответить | Цитировать | Написать

VBA копирование диапазона: только значение и цвет (исключая всякое иное форматирование)

#39580804

Akina

Участник

Откуда: Зеленоград, Москва, Россия

Сообщения: 20 644

Рейтинг: 0 / 0

ВладимирГКнужно - только цвет ячеек! Где-то читал об использовании циклов, но этот вариант также не очень желателен, т.к. диапазонов много (40-50) и значений в каждом диапазоне может быть от 20 до 500 строк.Это - вариант, причём единственный.

...

Рейтинг:

0 / 0

09.01.2018, 07:52

| Ответить | Цитировать | Написать

VBA копирование диапазона: только значение и цвет (исключая всякое иное форматирование)

#39580922

Aster32

Гость

Примитивно решаем вопрос "в лоб":

Код: vbnet

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.

Sub ColorsCopy()
Dim N As Range
Dim SC As Range
Dim Z() As Variant
Dim ZZ() As Variant
Dim Y As Single
Set SC = Selection.Cells
Y = SC.Count
If Y = 1 Then MsgBox ("Your selection must be more than 1 cells!"): Exit Sub
ReDim Z(Y)
ReDim ZZ(Y)
For Each N In SC
M = M + 1
Z(M) = N.Value
ZZ(M) = N.Interior.Color
Next N
Sheets(2).Activate
For i = 1 To Y
Cells(i, 1).Value = Z(i)
Cells(i, 1).Interior.Color = ZZ(i)
Next i
End Sub

...

Рейтинг:

0 / 0

09.01.2018, 11:55

| Ответить | Цитировать | Написать

VBA копирование диапазона: только значение и цвет (исключая всякое иное форматирование)

#39581074

ВладимирГК

Гость

Ура, работает!!!!
Огромное спасибо за оперативность! То, что нужно!
Адаптирую в свой код и оценю скорость.
Спасибо Aster32! Здорово, что есть такой сайт и люди!

...

Рейтинг:

0 / 0

09.01.2018, 14:34

| Ответить | Цитировать | Написать

VBA копирование диапазона: только значение и цвет (исключая всякое иное форматирование)

#39581190

Казанский

Гость

Aster32,
1. зачем Value-то по одной ячейке переносить, Value образует массив!
2. Если исходная ячейка не имела окраски, результирующая получается белой, что не совсем правильно. Надо проверять

Код: vbnet

If N.Interior.ColorIndex = xlColorIndexNone Then 'присвоить результирующей ячейке .Interior.ColorIndex = xlColorIndexNone

Akina,
я не согласен, что это единственный вариант. Можно создать стиль, который "обнулит" все, кроме цвета ячейки, и применить его после вставки значений и форматов:

Код: vbnet

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.

Sub PasteValuesAndCellColors()
Const STYLE_NAME = "СохрЗаливку"                      'имя нашего стиля
  If Application.CutCopyMode = False Then
    MsgBox "Сначала скопируйте диапазон и выделите ячейку для вставки", vbInformation
  End If
  On Error Resume Next
  If ActiveWorkbook.Styles(STYLE_NAME) Is Nothing Then
    ActiveWorkbook.Styles.Add Name:=STYLE_NAME
    With ActiveWorkbook.Styles(STYLE_NAME)
      .IncludeNumber = True
      .IncludeFont = True
      .IncludeAlignment = True
      .IncludeBorder = True
      .IncludePatterns = False
      .IncludeProtection = True
    End With
  End If
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
  Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
      SkipBlanks:=False, Transpose:=False
  Selection.Style = STYLE_NAME
  Application.CutCopyMode = False
End Sub

...

Рейтинг:

0 / 0

09.01.2018, 17:23

| Ответить | Цитировать | Написать

VBA копирование диапазона: только значение и цвет (исключая всякое иное форматирование)

#39581436

ВладимирГК

Гость

Здравствуйте, Казанский!
Попытался запустить Ваш макрос - не получается!
Копирует значения и условное форматирование. Цвет не копирует. Что я делаю не так? Вот кусок макроса с моими адресами листов и ячеек.

Код: vbnet

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.

Sub ВыгрузкаНовыйВариант()
  
Worksheets("Способы").Range("tСпособыЗакупок[Способы закупок]").Copy
 
 Const STYLE_NAME = "СохрЗаливку"                      'имя стиля
  If Application.CutCopyMode = False Then
    MsgBox "Сначала скопируйте диапазон и выделите ячейку для вставки", vbInformation
  End If
On Error Resume Next
  If ActiveWorkbook.Styles(STYLE_NAME) Is Nothing Then
    ActiveWorkbook.Styles.Add Name:=STYLE_NAME
    With ActiveWorkbook.Styles(STYLE_NAME)
      .IncludeNumber = True
      .IncludeFont = True
      .IncludeAlignment = True
      .IncludeBorder = True
      .IncludePatterns = False
      .IncludeProtection = True
    End With
  End If

  Sheets("БД").Select
    Range("A30").Select
  
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
  Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
      SkipBlanks:=False, Transpose:=False
  Selection.Style = STYLE_NAME
  Application.CutCopyMode = False
  

End Sub

Модератор: Учимся использовать тэги оформления кода - FAQ

...

Рейтинг:

0 / 0

10.01.2018, 07:57

| Ответить | Цитировать | Написать

VBA копирование диапазона: только значение и цвет (исключая всякое иное форматирование)

#39581446

ВладимирГК

Гость

КазанскийAster32,
2. Если исходная ячейка не имела окраски, результирующая получается белой, что не совсем правильно. Надо проверять

Код: vbnet

If N.Interior.ColorIndex = xlColorIndexNone Then 'присвоить результирующей ячейке .Interior.ColorIndex = xlColorIndexNone

Да, Вы правы, окрашивает в белый цвет и это не корректно. Но у меня не получается вставить в код, предложенный Aster32, Вашу проверку. Подскажите, пожалуйста, куда и как это нужно сделать.
Спасибо за помощь!

...

Рейтинг:

0 / 0

10.01.2018, 08:29

| Ответить | Цитировать | Написать

VBA копирование диапазона: только значение и цвет (исключая всякое иное форматирование)

#39581736

Aster32

Гость

Проверка при записи массива цветов, и проверка при "воспроизведении" на новом листе:

Код: vbnet

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.

Sub ColorsCopy()
Dim N As Range
Dim SC As Range
Dim Z() As Variant
Dim ZZ() As Variant
Dim Y As Single
Set SC = Selection.Cells
Y = SC.Count
If Y = 1 Then MsgBox ("Your selection must be more than 1 cells!"): Exit Sub
ReDim Z(Y)
ReDim ZZ(Y)
For Each N In SC
M = M + 1
Z(M) = N.Value
If N.Interior.ColorIndex = xlColorIndexNone Then
ZZ(M) = -1
Else
ZZ(M) = N.Interior.Color
End If
Next N
Sheets(2).Activate
For i = 1 To Y
Cells(i, 1).Value = Z(i)
If ZZ(i) = -1 Then
Cells(i, 1).Interior.ColorIndex = xlColorIndexNone
Else
Cells(i, 1).Interior.Color = ZZ(i)
End If
Next i
End Sub

...

Рейтинг:

0 / 0

10.01.2018, 14:16

| Ответить | Цитировать | Написать

VBA копирование диапазона: только значение и цвет (исключая всякое иное форматирование)

#39582031

Казанский

Гость

ВладимирГК,
приложите пример файла, попробую допилить этот метод.
А пока вариант с поячеечным переносом цвета

Код: vbnet

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.

Sub ВыгрузкаНовыйВариант()
Dim d As Range, i&, c&
  With Worksheets("Способы").Range("tСпособыЗакупок[Способы закупок]") '.Copy
    Set d = Sheets("БД").Range("A30").Resize(.Count)
    d.Value = .Value
    For i = 1 To .Count
      c = .Cells(i).Interior.ColorIndex
      If c < 0 Then
        d.Cells(i).Interior.ColorIndex = c
      Else
        d.Cells(i).Interior.Color = .Cells(i).Interior.Color
      End If
    Next
  End With
End Sub

...

Рейтинг:

0 / 0

10.01.2018, 19:24

| Ответить | Цитировать | Написать

VBA копирование диапазона: только значение и цвет (исключая всякое иное форматирование)

#39582110

ВладимирГК

Гость

Друзья, спасибо за столь активную помощь, даже не ожидал!!!!!

Aster32, так как вариант товарища Казанского у меня пока не рабочий, то я сконцентрировался на Вашем. Учёл проверку на цвет, всё работает! И это уже очень здорово, т.к. не руками, а таки автоматически делается. Но когда запустил в цикл отработку всех необходимых для копирования диапазонов, а их сейчас, когда база неполная - 29 столбцов по 211 строк, - получаю выгрузку больше получаса! А ожидается - около 500 строк в 29 столбцах!!!
Да, выгрузка будет нужна не каждый день. Может быть - несколько раз в месяц. Но такое время выполнения - это настораживает! А ведь потом ещё в другое место закачивать!
Очень хочется быстрее!
Уважаемый Казанский, также искренне благодарю за участие в решении моей задачи. Завтра попробую Ваш доработанный вариант адаптировать и запустить. Посмотрю по работоспособности и скорости. Честно говоря, сходу не понял - у меня глубокая ночь, видимо торможу уже. Что касается файла, постараюсь откусить работоспособный кусок из проекта и обязательно Вам направлю.

Ещё раз всем большое спасибо!!!

...

Рейтинг:

0 / 0

10.01.2018, 22:11

| Ответить | Цитировать | Написать

VBA копирование диапазона: только значение и цвет (исключая всякое иное форматирование)

#39582199

ВладимирГК

Гость

Уважаемые товарищи, я был неточен! Время работы выгрузки оценил приблизительно, т.к. не дожидался конца выполнения процедуры. Сегодня с утра набрался терпения и дождался конца. Один час и четыре минуты!!! Основная доля - 99% времени - это отработка моих 29 столбцов. Остальные диапазоны (а их - пару десятков) копируются без цвета, а поэтому - быстро (копировать-вставить диапазон). Проблема!!! Как быть? К коду ув. Казанского пока не приступал, может там спасение... Но сейчас - намазал лыжи - поеду свежего воздуха глотну часок-другой.

...

Рейтинг:

0 / 0

11.01.2018, 07:18

| Ответить | Цитировать | Написать

VBA копирование диапазона: только значение и цвет (исключая всякое иное форматирование)

#39582369

ВладимирГК

Гость

Уважаемый Казанский!
Я на свежую голову довольно быстро (как я полагаю для моего начального уровня) разобрался с последним Вашим предложением.
Это невероятно!!!! Всё просто летает!!! Низкий Вам поклон! Сейчас займусь адаптацией для всех 29-ти диапазонов и отрапортую по итоговому времени выполнения!

...

Рейтинг:

0 / 0

11.01.2018, 11:47

| Ответить | Цитировать | Написать

VBA копирование диапазона: только значение и цвет (исключая всякое иное форматирование)

#39582443

ВладимирГК

Гость

_{Set d = Sheets("ÁÄ").Range("V30").Resize(.count)

Set d = Sheets("ÁÄ").Range(Cells(ÑòðîêàÇàãîëîâêîâ + 1, diap)).Resize(.count)}

Подскажите, в чем ошибка во второй строке. Я себе представляю, что это одно и то же. Но первая строка рабочая, а на вторую выдаётся ошибка Applucation-defined or object defined error. При этом переменные существуют. "СтрокаЗаголовков" = 29, "diap" = 22. Т.е. адрес ячейки "V30", как в первой строке. Неправильно через Cells переписал?

...

Рейтинг:

0 / 0

11.01.2018, 12:45

| Ответить | Цитировать | Написать

VBA копирование диапазона: только значение и цвет (исключая всякое иное форматирование)

#39582446

ВладимирГК

Гость

Код: vbnet

1.
2.

Set d = Sheets("БД").Range("V30").Resize(.count)
Set d = Sheets("БД").Range(Cells(СтрокаЗаголовков + 1, diap)).Resize(.count)

Вот, кажется научился вставлять, прошу прощения за неграмотность.

...

Рейтинг:

0 / 0

11.01.2018, 12:52

| Ответить | Цитировать | Написать

VBA копирование диапазона: только значение и цвет (исключая всякое иное форматирование)

#39582448

Казанский

Гость

ВладимирГК,

Код: vbnet

Set d = Sheets("БД").Cells(СтрокаЗаголовков + 1, diap).Resize(.count)

...

Рейтинг:

0 / 0

11.01.2018, 12:54

| Ответить | Цитировать | Написать

VBA копирование диапазона: только значение и цвет (исключая всякое иное форматирование)

#39582451

ВладимирГК

Гость

Код: vbnet

    Set d = Sheets("БД").Cells(СтрокаЗаголовков + 1, diap).Resize(.count)

Всё, разобрался!!!!!

...

Рейтинг:

0 / 0

11.01.2018, 12:56

| Ответить | Цитировать | Написать

VBA копирование диапазона: только значение и цвет (исключая всякое иное форматирование)

#39582498

ВладимирГК

Гость

Фанфарыыы!!!!!
Всё работает отлично! Перевёл на данный способ копирование и других диапазонов, где нужны были только значения (без переноса цвета).
Время выполнения ВСЕГО - 1 минута 31 секунда!!!
Уважаемый Казанский, я снимаю шляпу!
Ещё раз огромное спасибо неравнодушным Akina и Aster32 - Вы меня многому научили!
Задача решена!

...

Рейтинг:

0 / 0

11.01.2018, 14:01

| Ответить | Цитировать | Написать

17 сообщений из 17, страница 1 из 1

Цитировать

Написать

Автор*:

Ввести пароль для входа

Тема*:

Сообщение

Данное сообщение тематическое

Сообщение содержит картинки или видео 18+

Автор:

ВНИМАНИЕ! На данном подфоруме действуют строгие правила. Удостоверьтесь, что ваше сообщение соответствует им!

Форум или тема закрыты для гостей. Необходима авторизация!

Загрузить последнюю сохраненную версию

Вложение:

Вставить как галерею

Максимальный размер вложений: 4,0 МБ, аудио/видео: 8,0 МБ. Картинки большего размера ужимаются, если возможно.

Введите код, изображенный на картинке. Если код нечитаемый, кликните картинку, чтобы загрузить другой вариант.

Отправляя сообщение, я выражаю свое согласие с правилами форума и принимаю пользовательское соглашение.

Читали тему (0):

Читали форум (0):

Пользователи онлайн (0):

start [/forum/topic.php?fid=60&fpage=12&tid=2155133]:	0ms
get settings:	8ms
get forum list:	13ms
check forum access:	3ms
check topic access:	3ms
track hit:	637ms
get topic data:	11ms
get forum data:	2ms
get page messages:	47ms
get tp. blocked users:	1ms
others:	11ms

total:	736ms