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

Вход

Регистрация

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

 

= Мир MS Excel/Поиск и перенос данных с учетом цвета ячейки - Мир MS Excel

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

Excel 2016
Добрый день. Надеюсь, что кто-нибудь из Вас сталкивался с подобным. Рассчитываю на Вашу мудрость))
Предыстория:
Прикладываемые файлы урезаны, но их оригиналы содержат большое кол-во формул и расчетов. Поэтому не хотелось бы глобально изменять табличную часть. Также не рассматривается переход на плоскую таблицу.
Условия:
1) Дан ряд файлов “*.xlms”, с последовательным наименованием (03.18, 04.18, 05.18)
2) Каждый документ состоит более чем из 20 листов идентичных по форме заполнения, отличающихся данными.
3) У каждого листа имеется наименование (название розничной точки) , также книга содержит несколько листов с общими данными.
Задача:
В идеале – создать кнопку (Пересчет) на листе Доп.данные. Которая:
1) При использовании функции “Индекс Поискпоз”, на листах (от Магазин№1 до Магазин№Х), в массиве C7:H26 , переносила бы не только значения, вычисленные функцией, но и цвет их ячеек.
Это будет? другой пост. Отвечающих просьба пока решать только первый вопрос. Борода
2) Для того, чтобы не было необходимости каждый раз переписывать функцию (индекс поискпоз) в том же диапазоне C7:H26, необходима возможность изменять часть текста функции, используя ячейку или всплывающее окно.
Код
{=ЕСЛИ(H$6="";"";ЕСЛИ((ИНДЕКС('[04.18.xlsm]Магазин №1'!$J$7:$AN$26;ПОИСКПОЗ($A$5&$B7;'[04.18.xlsm]Магазин №1'!$A$5&'[04.18.xlsm]Магазин №1'!$B$7:$B$26;0);ПОИСКПОЗ(H$6;'[04.18.xlsm]Магазин №1'!$J$1:$AN$1;0)))>0;ИНДЕКС('[04.18.xlsm]Магазин №1'!$J$7:$AN$26;ПОИСКПОЗ($A$5&$B7;'[04.18.xlsm]Магазин №1'!$A$5&'[04.18.xlsm]Магазин №1'!$B$7:$B$26;0);ПОИСКПОЗ(H$6;'[04.18.xlsm]Магазин №1'!$J$1:$AN$1;0));""))}

Как видно из функции, она ссылается на документ [04.18.xlsm] из документа 05.18. Но по прошествии месяца, мне придется переписывать функцию, ссылаясь на документ [05.18.xlsm] из документа 06.18.
Отлично бы реализовать следующее:
При нажатии на кнопку “Пересчет” происходило не только перетягивание данных с цветом ячейки, но и изменение функцИЙ (индекс поискпоз), в массиве C7:H26, на листах магазинов, на основании ячейки D2(отражающую документ на который ссылается функция)

P.S. - мне рекомендовали создать тему в этой ветке.
К сообщению приложен файл: 8836069.xlsm(69.1 Kb) · 2243419.xlsm(74.5 Kb)
 
Ответить
СообщениеДобрый день. Надеюсь, что кто-нибудь из Вас сталкивался с подобным. Рассчитываю на Вашу мудрость))
Предыстория:
Прикладываемые файлы урезаны, но их оригиналы содержат большое кол-во формул и расчетов. Поэтому не хотелось бы глобально изменять табличную часть. Также не рассматривается переход на плоскую таблицу.
Условия:
1) Дан ряд файлов “*.xlms”, с последовательным наименованием (03.18, 04.18, 05.18)
2) Каждый документ состоит более чем из 20 листов идентичных по форме заполнения, отличающихся данными.
3) У каждого листа имеется наименование (название розничной точки) , также книга содержит несколько листов с общими данными.
Задача:
В идеале – создать кнопку (Пересчет) на листе Доп.данные. Которая:
1) При использовании функции “Индекс Поискпоз”, на листах (от Магазин№1 до Магазин№Х), в массиве C7:H26 , переносила бы не только значения, вычисленные функцией, но и цвет их ячеек.
Это будет? другой пост. Отвечающих просьба пока решать только первый вопрос. Борода
2) Для того, чтобы не было необходимости каждый раз переписывать функцию (индекс поискпоз) в том же диапазоне C7:H26, необходима возможность изменять часть текста функции, используя ячейку или всплывающее окно.
Код
{=ЕСЛИ(H$6="";"";ЕСЛИ((ИНДЕКС('[04.18.xlsm]Магазин №1'!$J$7:$AN$26;ПОИСКПОЗ($A$5&$B7;'[04.18.xlsm]Магазин №1'!$A$5&'[04.18.xlsm]Магазин №1'!$B$7:$B$26;0);ПОИСКПОЗ(H$6;'[04.18.xlsm]Магазин №1'!$J$1:$AN$1;0)))>0;ИНДЕКС('[04.18.xlsm]Магазин №1'!$J$7:$AN$26;ПОИСКПОЗ($A$5&$B7;'[04.18.xlsm]Магазин №1'!$A$5&'[04.18.xlsm]Магазин №1'!$B$7:$B$26;0);ПОИСКПОЗ(H$6;'[04.18.xlsm]Магазин №1'!$J$1:$AN$1;0));""))}

Как видно из функции, она ссылается на документ [04.18.xlsm] из документа 05.18. Но по прошествии месяца, мне придется переписывать функцию, ссылаясь на документ [05.18.xlsm] из документа 06.18.
Отлично бы реализовать следующее:
При нажатии на кнопку “Пересчет” происходило не только перетягивание данных с цветом ячейки, но и изменение функцИЙ (индекс поискпоз), в массиве C7:H26, на листах магазинов, на основании ячейки D2(отражающую документ на который ссылается функция)

P.S. - мне рекомендовали создать тему в этой ветке.

Автор - EvgeniyVS
Дата добавления - 14.05.2018 в 15:55
_Boroda_ Дата: Понедельник, 14.05.2018, 16:14 | Сообщение № 2
Группа: Модераторы
Ранг: Местный житель
Сообщений: 12097
Репутация: 4988 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Правила форума
Один вопрос - одна тема
Оставляйте в этой теме один вопрос, а второй задавайте в другой.


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеПравила форума
Один вопрос - одна тема
Оставляйте в этой теме один вопрос, а второй задавайте в другой.

Автор - _Boroda_
Дата добавления - 14.05.2018 в 16:14
EvgeniyVS Дата: Понедельник, 14.05.2018, 16:30 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 19
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
_Boroda_, добрый день.
Я описал задачу целиком, чтобы была возможность увидеть картину в целом.
Что если реализовать решение через VBA, не используя (ИндексПоискпоз).

Но если выбрать необходимо, то я ищу помощь в написании кода, который позволит переносить не только данные но и цвет ячейки.
Мне необходимо внести изменения в первоначальный пост?
 
Ответить
Сообщение_Boroda_, добрый день.
Я описал задачу целиком, чтобы была возможность увидеть картину в целом.
Что если реализовать решение через VBA, не используя (ИндексПоискпоз).

Но если выбрать необходимо, то я ищу помощь в написании кода, который позволит переносить не только данные но и цвет ячейки.
Мне необходимо внести изменения в первоначальный пост?

Автор - EvgeniyVS
Дата добавления - 14.05.2018 в 16:30
SLAVICK Дата: Понедельник, 14.05.2018, 17:43 | Сообщение № 4
Группа: Модераторы
Ранг: Старожил
Сообщений: 2206
Репутация: 739 ±
Замечаний: 0% ±

2007,2010,2013,2016
как то так:
[vba]
Код
Sub FindValues_WithColors()
Dim Wb As Workbook
Dim mSh As Worksheet, Sh As Worksheet
Dim i&, ii&, StrRo, StrCo, iT&, iiT&

For Each mSh In ActiveWindow.SelectedSheets
    mSh.Select
    Set Wb = Workbooks.Open(ActiveWorkbook.Path & "\" & mSh.Range("d1").Value)
    Set Sh = Wb.Sheets(mSh.Name)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    For i = 7 To mSh.UsedRange.Rows.Count
        If Len(mSh.Cells(i, 2)) = 0 Then Exit For
        StrRo = mSh.Cells(i, 2)
        For ii = 3 To 8
            StrCo = mSh.Cells(6, ii)
            For iT = 7 To Sh.UsedRange.Rows.Count
                For iiT = 10 To 50
                    If StrRo = Sh.Cells(iT, 2) And StrCo = Sh.Cells(1, iiT) Then
                        mSh.Cells(i, ii).Value = Sh.Cells(iT, iiT).Value
                        mSh.Cells(i, ii).Interior.Color = Sh.Cells(iT, iiT).Interior.Color
                    End If
                Next
            Next
        Next
    Next
    Wb.Close False
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
[/vba]
К сообщению приложен файл: 06.18.xlsm(82.4 Kb)


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщениекак то так:
[vba]
Код
Sub FindValues_WithColors()
Dim Wb As Workbook
Dim mSh As Worksheet, Sh As Worksheet
Dim i&, ii&, StrRo, StrCo, iT&, iiT&

For Each mSh In ActiveWindow.SelectedSheets
    mSh.Select
    Set Wb = Workbooks.Open(ActiveWorkbook.Path & "\" & mSh.Range("d1").Value)
    Set Sh = Wb.Sheets(mSh.Name)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    For i = 7 To mSh.UsedRange.Rows.Count
        If Len(mSh.Cells(i, 2)) = 0 Then Exit For
        StrRo = mSh.Cells(i, 2)
        For ii = 3 To 8
            StrCo = mSh.Cells(6, ii)
            For iT = 7 To Sh.UsedRange.Rows.Count
                For iiT = 10 To 50
                    If StrRo = Sh.Cells(iT, 2) And StrCo = Sh.Cells(1, iiT) Then
                        mSh.Cells(i, ii).Value = Sh.Cells(iT, iiT).Value
                        mSh.Cells(i, ii).Interior.Color = Sh.Cells(iT, iiT).Interior.Color
                    End If
                Next
            Next
        Next
    Next
    Wb.Close False
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
[/vba]

Автор - SLAVICK
Дата добавления - 14.05.2018 в 17:43
EvgeniyVS Дата: Вторник, 15.05.2018, 09:16 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 19
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
SLAVICK, доброе утро.
И снова Вы выручаете, спасибо.
Правильно ли я понял, что данная формула отвечает за изменение (индек споискпоз)?
К сожалению, не удалось восстановить ее работоспособность.
И еще вопрос: Возможно ли вшить перечень листов в код, а кнопку перенести на лист доп.данные?
 
Ответить
СообщениеSLAVICK, доброе утро.
И снова Вы выручаете, спасибо.
Правильно ли я понял, что данная формула отвечает за изменение (индек споискпоз)?
К сожалению, не удалось восстановить ее работоспособность.
И еще вопрос: Возможно ли вшить перечень листов в код, а кнопку перенести на лист доп.данные?

Автор - EvgeniyVS
Дата добавления - 15.05.2018 в 09:16
SLAVICK Дата: Вторник, 15.05.2018, 09:30 | Сообщение № 6
Группа: Модераторы
Ранг: Старожил
Сообщений: 2206
Репутация: 739 ±
Замечаний: 0% ±

2007,2010,2013,2016
что данная формула отвечает за изменение (индек споискпоз)?

нет.
Этот макрос открывает книгу,название которой находится в зеленой ячейке D1, которая находится в той же папке, что и текущая книга.
ищет ФИО на одноименном листе в этой книге, и дату - и, если находит - подставляет уже готовые значения И ЗАЛИВКУ в столбцы "С-Н"
Таким образом необходимость в формуле - и ее изменении отпадает.
К сожалению, не удалось восстановить ее работоспособность.

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

для этого замените
[vba]
Код
ActiveWindow.SelectedSheets
[/vba]
на
[vba]
Код
Sheets(Array("Магазин №1", "Магазин №2"))
[/vba]
Добавлено
Почему у вас в магазине 1 и магазине 2 - разная структура и формулы?
Данные начинаются с 4-го столбца, а не с 10-го - но это полбеды
Формулы в одном листе - возвращают текстовое представление даты, а во втором - числовое.
Чтобы макрос работал одинаково - сделайте идентичными эти листы.
Еще добавлено:
сделал 2-й файл - там принудительное преобразование к числовому выражению даты и просмотр с 4-го столбца - теперь отрабатывает на двух листах.
К сообщению приложен файл: 06.18-1-.xlsm(83.1 Kb) · 06.18-1-2018-05.xlsm(81.6 Kb)


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
что данная формула отвечает за изменение (индек споискпоз)?

нет.
Этот макрос открывает книгу,название которой находится в зеленой ячейке D1, которая находится в той же папке, что и текущая книга.
ищет ФИО на одноименном листе в этой книге, и дату - и, если находит - подставляет уже готовые значения И ЗАЛИВКУ в столбцы "С-Н"
Таким образом необходимость в формуле - и ее изменении отпадает.
К сожалению, не удалось восстановить ее работоспособность.

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

для этого замените
[vba]
Код
ActiveWindow.SelectedSheets
[/vba]
на
[vba]
Код
Sheets(Array("Магазин №1", "Магазин №2"))
[/vba]
Добавлено
Почему у вас в магазине 1 и магазине 2 - разная структура и формулы?
Данные начинаются с 4-го столбца, а не с 10-го - но это полбеды
Формулы в одном листе - возвращают текстовое представление даты, а во втором - числовое.
Чтобы макрос работал одинаково - сделайте идентичными эти листы.
Еще добавлено:
сделал 2-й файл - там принудительное преобразование к числовому выражению даты и просмотр с 4-го столбца - теперь отрабатывает на двух листах.

Автор - SLAVICK
Дата добавления - 15.05.2018 в 09:30
EvgeniyVS Дата: Вторник, 15.05.2018, 15:19 | Сообщение № 7
Группа: Пользователи
Ранг: Новичок
Сообщений: 19
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
SLAVICK, не знаю как Вас и благодарить.
Тестирование пройдено успешно!
Но вот пытаясь интегрировать в рабочий документ, получаю ошибку :
Run-time error '9':
Subscript out of range

в Sheets(Array("Магазин №1", "Магазин №2")) я прописал около 20 магазинов(в кавычках и через запятую).
Имеет ли значение очередность листов у сравниваемых файлов?
 
Ответить
СообщениеSLAVICK, не знаю как Вас и благодарить.
Тестирование пройдено успешно!
Но вот пытаясь интегрировать в рабочий документ, получаю ошибку :
Run-time error '9':
Subscript out of range

в Sheets(Array("Магазин №1", "Магазин №2")) я прописал около 20 магазинов(в кавычках и через запятую).
Имеет ли значение очередность листов у сравниваемых файлов?

Автор - EvgeniyVS
Дата добавления - 15.05.2018 в 15:19
SLAVICK Дата: Вторник, 15.05.2018, 15:37 | Сообщение № 8
Группа: Модераторы
Ранг: Старожил
Сообщений: 2206
Репутация: 739 ±
Замечаний: 0% ±

2007,2010,2013,2016
А во всех листах в ячейке Д1 имеется название книги?
Смотрите пошагово на каком листе спотыкается.
Возможно у вас в новой книге какие-то листы названы по другому.


Иногда все проще чем кажется с первого взгляда.
 
Ответить
СообщениеА во всех листах в ячейке Д1 имеется название книги?
Смотрите пошагово на каком листе спотыкается.
Возможно у вас в новой книге какие-то листы названы по другому.

Автор - SLAVICK
Дата добавления - 15.05.2018 в 15:37
EvgeniyVS Дата: Вторник, 15.05.2018, 16:53 | Сообщение № 9
Группа: Пользователи
Ранг: Новичок
Сообщений: 19
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
SLAVICK,

Цитата
А во всех листах в ячейке Д1 имеется название книги?

-Да

Цитата
Смотрите пошагово на каком листе спотыкается.

-После запуска функции, тормозит на этой строке:
Код
For Each mSh In Sheets(Array("Магазин 1", "и т.д.")) 'ActiveWindow.SelectedSheets
Попробовал применить Ваш код без указания листов, код стартует и заканчивается, но ничего не подтягивает.

Цитата
Возможно у вас в новой книге какие-то листы названы по другому.

Не думаю. Мы дублируем документ создавая новый месяц.
 
Ответить
СообщениеSLAVICK,

Цитата
А во всех листах в ячейке Д1 имеется название книги?

-Да

Цитата
Смотрите пошагово на каком листе спотыкается.

-После запуска функции, тормозит на этой строке:
Код
For Each mSh In Sheets(Array("Магазин 1", "и т.д.")) 'ActiveWindow.SelectedSheets
Попробовал применить Ваш код без указания листов, код стартует и заканчивается, но ничего не подтягивает.

Цитата
Возможно у вас в новой книге какие-то листы названы по другому.

Не думаю. Мы дублируем документ создавая новый месяц.

Автор - EvgeniyVS
Дата добавления - 15.05.2018 в 16:53
SLAVICK Дата: Вторник, 15.05.2018, 22:36 | Сообщение № 10
Группа: Модераторы
Ранг: Старожил
Сообщений: 2206
Репутация: 739 ±
Замечаний: 0% ±

2007,2010,2013,2016
тормозит на этой строке:

скорее всего какой-то из листов назван не верно, может пробел лишний или еще что. Начните с одного - и добавляйте по одному - тогда будет понятно.
Или ложите сюда файлы - со всеми листами - можно без заполненных др. данных.


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
тормозит на этой строке:

скорее всего какой-то из листов назван не верно, может пробел лишний или еще что. Начните с одного - и добавляйте по одному - тогда будет понятно.
Или ложите сюда файлы - со всеми листами - можно без заполненных др. данных.

Автор - SLAVICK
Дата добавления - 15.05.2018 в 22:36
EvgeniyVS Дата: Среда, 16.05.2018, 09:50 | Сообщение № 11
Группа: Пользователи
Ранг: Новичок
Сообщений: 19
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
SLAVICK,

Цитата
скорее всего какой-то из листов назван не верно, может пробел лишний или еще что. Начните с одного - и добавляйте по одному - тогда будет понятно.

Вы были правы! Не знаю, что конкретно вызывало ошибку, но после того, как я прошелся по каждому листу, ошибка исчезла.
Спасибо!

У меня еще один вопрос:
А Ваш код, он сканирует весь столбец с фамилиями? Если да, можно ли его ограничить областью (B8:B27)?
Также можно указать и область часов работы = (J7:AN26). Если конечно, это позволит снизить нагрузку.
При старте макроса, exel висит около минуты.
 
Ответить
СообщениеSLAVICK,

Цитата
скорее всего какой-то из листов назван не верно, может пробел лишний или еще что. Начните с одного - и добавляйте по одному - тогда будет понятно.

Вы были правы! Не знаю, что конкретно вызывало ошибку, но после того, как я прошелся по каждому листу, ошибка исчезла.
Спасибо!

У меня еще один вопрос:
А Ваш код, он сканирует весь столбец с фамилиями? Если да, можно ли его ограничить областью (B8:B27)?
Также можно указать и область часов работы = (J7:AN26). Если конечно, это позволит снизить нагрузку.
При старте макроса, exel висит около минуты.

Автор - EvgeniyVS
Дата добавления - 16.05.2018 в 09:50
SLAVICK Дата: Среда, 16.05.2018, 10:01 | Сообщение № 12
Группа: Модераторы
Ранг: Старожил
Сообщений: 2206
Репутация: 739 ±
Замечаний: 0% ±

2007,2010,2013,2016
столбец с фамилиями?

нет только до первой пустой ячейки в столбце 2:[vba]
Код
If Len(mSh.Cells(i, 2)) = 0 Then Exit For
[/vba]

указать и область часов работы = (J7:AN26)

за это отвечает строка[vba]
Код
For iiT = 10 To 50
[/vba]тут 10-50(в новом макросе 4 to 50) - это с какого по какой столбец искать даты.

При старте макроса, exel висит около минуты.

я и не пытался его оптимизировать - чтоб работал быстрее - нужно поиски в массивах делать и копировать форматы на диапазон сразу - а не в каждую ячейку отдельно.
Это еще большой кусок работы и мне лениво этим заниматся.
Тем более вам нужно его запускать раз в месяц - можно и подождать пару минут - чаю попить.


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
столбец с фамилиями?

нет только до первой пустой ячейки в столбце 2:[vba]
Код
If Len(mSh.Cells(i, 2)) = 0 Then Exit For
[/vba]

указать и область часов работы = (J7:AN26)

за это отвечает строка[vba]
Код
For iiT = 10 To 50
[/vba]тут 10-50(в новом макросе 4 to 50) - это с какого по какой столбец искать даты.

При старте макроса, exel висит около минуты.

я и не пытался его оптимизировать - чтоб работал быстрее - нужно поиски в массивах делать и копировать форматы на диапазон сразу - а не в каждую ячейку отдельно.
Это еще большой кусок работы и мне лениво этим заниматся.
Тем более вам нужно его запускать раз в месяц - можно и подождать пару минут - чаю попить.

Автор - SLAVICK
Дата добавления - 16.05.2018 в 10:01
EvgeniyVS Дата: Четверг, 17.05.2018, 09:13 | Сообщение № 13
Группа: Пользователи
Ранг: Новичок
Сообщений: 19
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
SLAVICK,

Цитата
Тем более вам нужно его запускать раз в месяц - можно и подождать пару минут - чаю попить.

И то верно!)

Но если вдруг время появится - знайте, никто не против))

Еще раз, большое спасибо за помощь!
 
Ответить
СообщениеSLAVICK,

Цитата
Тем более вам нужно его запускать раз в месяц - можно и подождать пару минут - чаю попить.

И то верно!)

Но если вдруг время появится - знайте, никто не против))

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

Автор - EvgeniyVS
Дата добавления - 17.05.2018 в 09:13
EvgeniyVS Дата: Вторник, 22.05.2018, 14:02 | Сообщение № 14
Группа: Пользователи
Ранг: Новичок
Сообщений: 19
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
SLAVICK,
Добрый день.
Снова нуждаюсь в Вашей помощи)
Можно ли внести изменения в код, чтобы заполнялись только столбцы имеющие дату в 6-ой строке ?
К сообщению приложен файл: 4336993.jpg(68.6 Kb)


Сообщение отредактировал EvgeniyVS - Вторник, 22.05.2018, 14:03
 
Ответить
СообщениеSLAVICK,
Добрый день.
Снова нуждаюсь в Вашей помощи)
Можно ли внести изменения в код, чтобы заполнялись только столбцы имеющие дату в 6-ой строке ?

Автор - EvgeniyVS
Дата добавления - 22.05.2018 в 14:02
StoTisteg Дата: Вторник, 22.05.2018, 14:44 | Сообщение № 15
Группа: Авторы
Ранг: Ветеран
Сообщений: 749
Репутация: 58 ±
Замечаний: 0% ±

Excel 2010
Глубоко в код не вникал, но можно попробовать, если в 6 строке может быть только дата, заменить
[vba]
Код
If StrRo = Sh.Cells(iT, 2) And StrCo = Sh.Cells(1, iiT) Then
[/vba] на
[vba]
Код
If StrRo = Sh.Cells(iT, 2) And StrCo = Sh.Cells(1, iiT) And Sh.Cells(iT, 6).Value<>"" Then
[/vba]


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
СообщениеГлубоко в код не вникал, но можно попробовать, если в 6 строке может быть только дата, заменить
[vba]
Код
If StrRo = Sh.Cells(iT, 2) And StrCo = Sh.Cells(1, iiT) Then
[/vba] на
[vba]
Код
If StrRo = Sh.Cells(iT, 2) And StrCo = Sh.Cells(1, iiT) And Sh.Cells(iT, 6).Value<>"" Then
[/vba]

Автор - StoTisteg
Дата добавления - 22.05.2018 в 14:44
SLAVICK Дата: Вторник, 22.05.2018, 14:50 | Сообщение № 16
Группа: Модераторы
Ранг: Старожил
Сообщений: 2206
Репутация: 739 ±
Замечаний: 0% ±

2007,2010,2013,2016
только столбцы имеющие дату в 6-ой строке

так макрос так и работает. Из вашего скрина ничего не понятно - не видно ни номеров строк ни названия столбцов.
[vba]
Код
For ii = 3 To 8
            StrCo = mSh.Cells(6, ii)
[/vba]
Значит, что данные дата, которая ищется - находится в 6-й строке.
Просматриваются столбцы с 3-го по 8-й


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
только столбцы имеющие дату в 6-ой строке

так макрос так и работает. Из вашего скрина ничего не понятно - не видно ни номеров строк ни названия столбцов.
[vba]
Код
For ii = 3 To 8
            StrCo = mSh.Cells(6, ii)
[/vba]
Значит, что данные дата, которая ищется - находится в 6-й строке.
Просматриваются столбцы с 3-го по 8-й

Автор - SLAVICK
Дата добавления - 22.05.2018 в 14:50
EvgeniyVS Дата: Вторник, 22.05.2018, 15:57 | Сообщение № 17
Группа: Пользователи
Ранг: Новичок
Сообщений: 19
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
SLAVICK,
Цитата
так макрос так и работает.

Хммм, значит я неверно интегрировал Ваш код. В связи с тем, что в апреле требовалось заполнить всех столбцов, я сразу не заметил возможный сбой.
Это не критично. Но вопрос открыт, если он не видит дату, откуда он берет инфу?

Цитата
не видно ни номеров строк ни названия столбцов



Еще один вопрос:
При запуске макроса, файл из которого подтягивается информация, имеет связи с другим файлом.
Таким образом, каждое открытие файла (зависит от количества листов в исходной книге ~20), сопровождается уведомлением о необходимости "обновить" или "не обновлять" связи.
Отойти (
Цитата
чаю попить.
) на время работы макроса к сожалению невозможно.
Может, что-то посоветуете?
К сообщению приложен файл: 8223497.jpg(42.0 Kb)
 
Ответить
СообщениеSLAVICK,
Цитата
так макрос так и работает.

Хммм, значит я неверно интегрировал Ваш код. В связи с тем, что в апреле требовалось заполнить всех столбцов, я сразу не заметил возможный сбой.
Это не критично. Но вопрос открыт, если он не видит дату, откуда он берет инфу?

Цитата
не видно ни номеров строк ни названия столбцов



Еще один вопрос:
При запуске макроса, файл из которого подтягивается информация, имеет связи с другим файлом.
Таким образом, каждое открытие файла (зависит от количества листов в исходной книге ~20), сопровождается уведомлением о необходимости "обновить" или "не обновлять" связи.
Отойти (
Цитата
чаю попить.
) на время работы макроса к сожалению невозможно.
Может, что-то посоветуете?

Автор - EvgeniyVS
Дата добавления - 22.05.2018 в 15:57
SLAVICK Дата: Вторник, 22.05.2018, 16:20 | Сообщение № 18
Группа: Модераторы
Ранг: Старожил
Сообщений: 2206
Репутация: 739 ±
Замечаний: 0% ±

2007,2010,2013,2016
Может, что-то посоветуете?

Чтоб не спрашивал про связи - можно открывать без обновления связей. Для этого нужно добавить три символа. Поменяйте строку:
[vba]
Код
Set Wb = Workbooks.Open(ActiveWorkbook.Path & "\" & mSh.Range("d1").Value)
[/vba]на
[vba]
Код
Set Wb = Workbooks.Open(ActiveWorkbook.Path & "\" & mSh.Range("d1").Value, 0)
[/vba]

если он не видит дату, откуда он берет инфу?

со строки с ФИО, и с пустым столбцом в датах.
Добавил проверку заполненности ячейки:
[vba]
Код
If Len(StrCo) > 4 Then
[/vba]
Теперь будет искать только если ячейка заполнена.:
[vba]
Код
Sub FindValues_WithColors()
Dim Wb As Workbook
Dim mSh As Worksheet, Sh As Worksheet
Dim i&, ii&, StrRo, StrCo, iT&, iiT&

For Each mSh In Sheets(Array("Магазин №1", "Магазин №2")) 'ActiveWindow.SelectedSheets
    mSh.Select
    Set Wb = Workbooks.Open(ActiveWorkbook.Path & "\" & mSh.Range("d1").Value, 0)
    Set Sh = Wb.Sheets(mSh.Name)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    For i = 7 To mSh.UsedRange.Rows.Count
        If Len(mSh.Cells(i, 2)) = 0 Then Exit For
        StrRo = mSh.Cells(i, 2)
        For ii = 3 To 8
            StrCo = mSh.Cells(6, ii)
            If Len(StrCo) Then
                For iT = 7 To Sh.UsedRange.Rows.Count
                    For iiT = 4 To 50
                        If StrRo = Sh.Cells(iT, 2) And Val(StrCo) = Val(Sh.Cells(1, iiT)) Then
                            mSh.Cells(i, ii).Value = Sh.Cells(iT, iiT).Value
                            mSh.Cells(i, ii).Interior.Color = Sh.Cells(iT, iiT).Interior.Color
                            Exit For
                        End If
                    Next
                Next
            End If
        Next
    Next
    Wb.Close False
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
[/vba]
К сообщению приложен файл: 4134219.xlsm(81.5 Kb)


Иногда все проще чем кажется с первого взгляда.

Сообщение отредактировал SLAVICK - Вторник, 22.05.2018, 16:22
 
Ответить
Сообщение
Может, что-то посоветуете?

Чтоб не спрашивал про связи - можно открывать без обновления связей. Для этого нужно добавить три символа. Поменяйте строку:
[vba]
Код
Set Wb = Workbooks.Open(ActiveWorkbook.Path & "\" & mSh.Range("d1").Value)
[/vba]на
[vba]
Код
Set Wb = Workbooks.Open(ActiveWorkbook.Path & "\" & mSh.Range("d1").Value, 0)
[/vba]

если он не видит дату, откуда он берет инфу?

со строки с ФИО, и с пустым столбцом в датах.
Добавил проверку заполненности ячейки:
[vba]
Код
If Len(StrCo) > 4 Then
[/vba]
Теперь будет искать только если ячейка заполнена.:
[vba]
Код
Sub FindValues_WithColors()
Dim Wb As Workbook
Dim mSh As Worksheet, Sh As Worksheet
Dim i&, ii&, StrRo, StrCo, iT&, iiT&

For Each mSh In Sheets(Array("Магазин №1", "Магазин №2")) 'ActiveWindow.SelectedSheets
    mSh.Select
    Set Wb = Workbooks.Open(ActiveWorkbook.Path & "\" & mSh.Range("d1").Value, 0)
    Set Sh = Wb.Sheets(mSh.Name)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    For i = 7 To mSh.UsedRange.Rows.Count
        If Len(mSh.Cells(i, 2)) = 0 Then Exit For
        StrRo = mSh.Cells(i, 2)
        For ii = 3 To 8
            StrCo = mSh.Cells(6, ii)
            If Len(StrCo) Then
                For iT = 7 To Sh.UsedRange.Rows.Count
                    For iiT = 4 To 50
                        If StrRo = Sh.Cells(iT, 2) And Val(StrCo) = Val(Sh.Cells(1, iiT)) Then
                            mSh.Cells(i, ii).Value = Sh.Cells(iT, iiT).Value
                            mSh.Cells(i, ii).Interior.Color = Sh.Cells(iT, iiT).Interior.Color
                            Exit For
                        End If
                    Next
                Next
            End If
        Next
    Next
    Wb.Close False
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
[/vba]

Автор - SLAVICK
Дата добавления - 22.05.2018 в 16:20
EvgeniyVS Дата: Вторник, 22.05.2018, 17:07 | Сообщение № 19
Группа: Пользователи
Ранг: Новичок
Сообщений: 19
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
SLAVICK,
Все работает - Великолепно!

- за столь крупный вклад в дело нашей организации, мы назовем первенца в Вашу честь)))

Спасибо!
 
Ответить
СообщениеSLAVICK,
Все работает - Великолепно!

- за столь крупный вклад в дело нашей организации, мы назовем первенца в Вашу честь)))

Спасибо!

Автор - EvgeniyVS
Дата добавления - 22.05.2018 в 17:07
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Поиск и перенос данных с учетом цвета ячейки (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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