С Новым годом! Форум программистов, компьютерный форум, киберфорум
VBA
Войти
Регистрация
Восстановить пароль
Карта форума Темы раздела Блоги Сообщество Поиск Заказать работу  
 
 
Рейтинг 4.91/70: Рейтинг темы: голосов - 70, средняя оценка - 4.91
0 / 0 / 0
Регистрация: 19.12.2019
Сообщений: 46
1
Excel

Excel Макрос для копирования информации из одной таблицы в другую по условию

10.03.2022, 17:13. Показов 13408. Ответов 52
Метки нет (Все метки)

Author24 — интернет-сервис помощи студентам
Добрый день.

Помогите доработать медленный макрос (см.файл макрос Nik035) или возможно кто то предложит альтернативный более шустрый вариант кода для моей задачи:

сам в этом совсем не разбираюсь

В эксель есть две таблицы

Левая - ОБЩАЯ исходная где есть все наименования и по которой идет отбор в СВОДНУЮ и только из тех строк для которых в ОБЩЕЙ проставлено какое то значение в графе - кол-во.

т.е. выбор по условию кол-во ЗНАКОВ в графе (графа Кол. > 0) не всегда знаки это число может быть что то типа 1* или * с форматированием в цвет (бел) для отображения пустой строки

В левой ОБЩЕЙ таблице будет порядка 200-300 наименований из которых по условию (графа Кол. > 0) строки копируются в СВОДНУЮ таблицу справа.

Сводную перед заполнением наверно нужно предварительно очищать.
Я так понимаю макрос из файла тормозит на переносе форматирования текста из ОБЩЕЙ таблицы, в принципе если по другому ускорить работу макроса не получится (кроме как убрав копирование этого форматирования текста) то можно этим пожертвовать или хотя бы оставить форматирование только для графы обозначение.

Всем откликнувшимся, заранее ОГРОМНОЕ спасибо!
Вложения
Тип файла: xls Nik_035.xls (62.5 Кб, 69 просмотров)
0
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
10.03.2022, 17:13
Ответы с готовыми решениями:

Макрос для копирования информации с одного листа в другой по условию
Приветствую ВАС,повелители Excel!!! Сил больше нет парсить это всё руками. Помогите написать...

Формула для копирования части данных из одной ячейки в другую - MS Excel
Здравствуйте Прошу вас о помощи Есть строка, она может быть любой длины. Из нее требуется...

Макрос для переноса данных из одной таблицы в другую
Всем привет. Нужно сделать макрос для заполнения двух столбцов одной таблицы данными из другой. Из...

Макрос копирования ячеек по условию в Excel
Здравствуйте господа программисты! Столкнулся с непосильной задачей. Знания в написании макросов...

Макрос копирования ячеек по условию в Excel
Здравствуйте господа программисты! Столкнулся с непосильной задачей. Знания в написании макросов...

52
0 / 0 / 0
Регистрация: 19.12.2019
Сообщений: 46
10.03.2022, 17:35  [ТС] 2
может можно как то сделать что бы копирование было не по отдельным ячейкам, а сразу по строкам типа:
rng.Range(Cells(rw, 1), Cells(rw, 6)).Copy Cells(cnt, 12)
0
0 / 0 / 0
Регистрация: 19.12.2019
Сообщений: 46
11.03.2022, 11:24  [ТС] 3
Совсем совсем не кому помочь?
0
552 / 482 / 191
Регистрация: 11.12.2013
Сообщений: 2,500
11.03.2022, 11:34 4
для того, чтобы ускорить перенос данных сформируйте массив и скопируйте его.
0
0 / 0 / 0
Регистрация: 19.12.2019
Сообщений: 46
11.03.2022, 12:04  [ТС] 5
Создать массив чего? и куда его скопировать

В файле задан диапазон ARM? но не знаю то это или не то? и если то то куда его нужно скопировать?
Так же попутный вопрос как сделать что бы в сводной таблице отображались значения как текст а не формула (если она будет в общей таблице)?

Добавлено через 9 минут
макрос модифицировал...стало значительно лучше

Visual Basic
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 Nik035()
Dim nms As Names ' коллекция именованных диапазонов книги
Dim nm As Name ' текущий именованный диапазон
Dim rng As Range ' диапазон соответствующий именованному диапазону
Dim rw As Integer ' номер строки в именованном диапазоне
Dim cl As Integer ' номер столба в именованном диапазоне
Range("L4:Q200").Select
    Selection.ClearContents
Dim cnt As Integer ' номер строки в сводной спецификации
cnt = 3
For Each nm In Names ' перебор именованных диапазонов
Set rng = Range(nm) ' получение диапазона
    cnt = cnt + 1 '
    rng.Cells(1, 3).Copy Cells(cnt, 14) ' копирование заголовка диапазона
    rng.Cells(1, 4).Copy Cells(cnt, 15) ' копирование *
For rw = 2 To rng.Rows.Count ' перебор диапазона
    If Len(rng.Cells(rw, 4)) > 0 Then ' если в столбце кол. не пусто добавляем строку
        cnt = cnt + 1 '
                   rng.Range(Cells(rw, 1), Cells(rw, 6)).Copy Cells(cnt, 12)
    End If
Next
Next
MsgBox "TheEnd!!!"
End Sub
теперь проблема в другом...работает нормально пока он в пустом файле без других листов.
При переносе листа в другой файл с наличием других диапазонов (печати, ВПР и т.д.) он отказывается работать...как быть?
то же самое происходит если листы из другого файла перенести в данный файл с макросом.
По итогу мне нужен общая книга эксель из нескольких листов в том числе с данным макросом

Добавлено через 7 минут
я совсем не специалист в макросах и поэтому предполагаю что проблема в наличии других разделов.
Возможно что это и не так
0
Модератор
Эксперт MS Access
12090 / 4950 / 791
Регистрация: 07.08.2010
Сообщений: 14,563
Записей в блоге: 4
11.03.2022, 12:29 6
ceatv,
почему пункты 5.11 и 5.12 повторяются 2 раза, оба с количеством

видимо и КИП , не имеющий количества , надо переносить, если он возглавляет группу строк с количеством
0
0 / 0 / 0
Регистрация: 19.12.2019
Сообщений: 46
11.03.2022, 14:03  [ТС] 7
Спасибо за вопросы...может хоть так получится найти проблему

учитывая что не совсем понимаю действий макроса (только по пояснениям для каждой строки) и то с натяжкой

про п. 5.11 и 5.12 наверно имеется ввиду 5 и 6?


5. Dim rw As Integer ' номер строки в именованном диапазоне
6. Dim cl As Integer ' номер столба в именованном диапазоне

п.6 - удалил...в отдельном файле макрос работает нормально, в другом файле с другими не привязанными к данному макросу диапазонами - не работает

Добавлено через 1 час 14 минут
Совсем нет ни каких предложений...что может быть не так в макросе? почему он не хочет работать в другом файле при наличии других именованных диапазонов с ним не связанных?
0
малоболт
1324 / 507 / 212
Регистрация: 30.01.2020
Сообщений: 1,230
11.03.2022, 14:21 8
ceatv, Давайте пройдёмся по теории.
1. Скорость
1.1 Каждое одно обращение к диапазону ячеек кушает время одинаковое вне зависимости от числа ячеек в данном диапазоне.
1.2. Когда число обращений переваливает за 100 - время обработки начинает измеряться секундами.
1.3. Обработка даже очень больших массивов в памяти занимает доли секунды.

То есть считать чохом лист с миллионом заполненных ячеек в массив = доли секунды.
Читать его поячеечно = доли секунды * кол-во ячеек = могут быть десятки минут при больших объемах
Обрабатывать данные миллиона ячеек, беря/сохраняя их из/в массивы - доли секунды
Обрабатывать те же миллионы, читая/записывая в цикле каждый раз значения из/в ячейки = десятки минут, если не часы.

Соответственно, если объём данных велик - оптимально считать всё в массив, обработать, подготовить выходной массив и залить его в нужный диапазон ячеек - такие программы отрабатывают даже на нескольких миллионах ячеек за время моргания глазом.
Вот только, если в каждой ячейке использовано разное форматирование частей текста, разные шрифты, наклон, выделение жирным и т.п. - это в массив не запишется: там только текст. Поэтому всю красивость таким образом быстро не перенести, как ни старайся, а только через Copy-Paste. Здесь тоже можно уменьшить число обращений к ячейкам, постаравшись копировать максимально крупными регионами.
Вот, например ниже ещё чуть более быстрый копировщик из вашего кода, который накапливает счётчик строк для копирования, пока не встретится пустая строка, и только потом переносит диапазон между пустыми строками в новое место. Если бы в нём ещё и количество не читать каждый раз из ячеек, а один раз считать в массив и потом перебирать элементы массива - было бы ещё быстрее.

2. Добавление листов и сбой работы макроса.

Когда у вас более одного листа, нельзя обращаться просто к Range или Cells. Нужно указывать лист, на котором эти Range и Cells обретаются. Например: Sheets(1).Range(Sheets(1).Cells(2,5),Sheets(1).Cells(50,12)).Value = ...
Или Sheets("ваше_имя_листа").Cells(2,12).Value = ...

А если вы открываете одновременно более одного файла Excel, то надо конкретизировать к какому WorkBooks() относятся ваши листы:
WorkBooks("test.xlsx").Sheets(1).Range...

Вот пример, который должен работать при наличии нескольких листов:
Visual Basic
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 Nik035()
 Dim nms As Names ' коллекция именованных диапазонов книги
 Dim nm As Name ' текущий именованный диапазон
 Dim rng As Range ' диапазон соответствующий именованному диапазону
 Dim rw As Integer ' номер строки в именованном диапазоне
 Dim sh1 'объект с нашим листом. 
 Set Sh1 = Sheets(1) 'Можно использовать Sheets("ИмяВашегоЛиста")
 Sh1.Range("L4:Q200").ClearContents
 Dim cnt As Integer ' номер строки в сводной спецификации
 cnt = 3
 For Each nm In Names ' перебор именованных диапазонов
   Set rng = Sh1.Range(nm) ' получение диапазона
   cnt = cnt + 1 '
   rng.Cells(1, 3).resize(1,2).Copy Sh1.Cells(cnt, 14) ' копирование заголовка диапазона
   PreRow = 2 'предыдущая непустая строка. Назначим первую проверяемую ею - пусть докажет!
   For rw = 2 To rng.Rows.Count ' перебор диапазона
     If Len(rng.Cells(rw, 4).text) = 0 Then ' если в столбце кол. пусто - копируем все строки между пустотами
       if PreRow < rw Then 'если предыдущая непустая строка не равна текущей - есть что переносить
         rng.Cells(PreRow, 1).resize(rw-PreRow,6).Copy Sh1.Cells(cnt, 12) ' копирование ячеек в сводную спецификацию
         cnt = cnt + rw - PreRow'
       end if
       PreRow = rw + 1'назначим следующую строку непустой. Пусть докажет!
     End If
   Next
   rw =rng.rows.count+1
   if PreRow < rw Then rng.Cells(PreRow, 1).resize(rw-PreRow,6).Copy Sh1.Cells(cnt, 12)
 Next
 
 MsgBox "TheEnd!!!"
End Sub
0
0 / 0 / 0
Регистрация: 19.12.2019
Сообщений: 46
11.03.2022, 14:52  [ТС] 9
спасибо! попробую, отпишусь по результату
0
0 / 0 / 0
Регистрация: 19.12.2019
Сообщений: 46
11.03.2022, 15:03  [ТС] 10
В отдельном файле работает

при переносе в другой файл или при добавлении листов в этот файл с макросом из другого файла - не работает

скан во вложении

при последовательном нажатии F8 на следующем после желтой строки ошибка
Миниатюры
Excel Макрос для копирования информации из одной таблицы в другую по условию  
0
0 / 0 / 0
Регистрация: 19.12.2019
Сообщений: 46
11.03.2022, 15:10  [ТС] 11
с ошибкой
Миниатюры
Excel Макрос для копирования информации из одной таблицы в другую по условию  
0
малоболт
1324 / 507 / 212
Регистрация: 30.01.2020
Сообщений: 1,230
11.03.2022, 15:20 12
Цитата Сообщение от ceatv Посмотреть сообщение
при последовательном нажатии F8 на следующем после желтой строки ошибк
Данного именованного диапазона нет на данном листе. То есть либо при переносе теряются именованные диапазоны, либо добавляются диапазоны, которых нет на данном листе, либо что-то ещё с ними происходит. А так важно использовать именно именованные диапазоны? Нельзя просто по ячейкам определённых столбцов определённого листа идти?
0
552 / 482 / 191
Регистрация: 11.12.2013
Сообщений: 2,500
11.03.2022, 16:57 13
Лучший ответ Сообщение было отмечено ceatv как решение

Решение

попробуйте так (без именованных диапазонов):
Visual Basic
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 newMacro()
    Dim iRows As Long, wrkSheet As Worksheet, i As Long
    Dim iRow As Long, bLineBreak As Boolean
    Dim iBegin As Integer, iEnd As Integer
    
    Application.ScreenUpdating = False
    Set wrkSheet = ActiveSheet
    iRows = wrkSheet.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    iRow = 3
    iEnd = 0
    iBegin = 0
    bLineBreak = False
    wrkSheet.Range("L4:Q" & CStr(iRows)).ClearContents
    
    For i = 4 To iRows
       If (((wrkSheet.Cells(i, 6) = "") And (wrkSheet.Cells(i, 5) <> "") And (wrkSheet.Cells(i, 4) <> "")) Or _
          ((wrkSheet.Cells(i, 6) = "") And (wrkSheet.Cells(i, 5) = "") And (wrkSheet.Cells(i, 4) = ""))) Then
          If (iBegin <> 0) Then
             If Not bLineBreak Then iRow = iRow - 1
             wrkSheet.Range("C" & CStr(iBegin) & ":H" & CStr(iEnd)).Copy wrkSheet.Cells(iRow + 1, 12)
             iRow = iRow + iEnd - iBegin + 2
             iBegin = 0
             iEnd = 0
          End If
          bLineBreak = ((wrkSheet.Cells(i, 6) = "") And (wrkSheet.Cells(i, 5) = "") And (wrkSheet.Cells(i, 4) = ""))
       Else
         If (iBegin = 0) Then iBegin = i
         iEnd = i
       End If
    Next i
    If iBegin <> 0 Then wrkSheet.Range("C" & CStr(iBegin) & ":H" & CStr(iEnd)).Copy wrkSheet.Cells(iRow + 1, 12)
    Application.ScreenUpdating = True
End Sub
1
0 / 0 / 0
Регистрация: 19.12.2019
Сообщений: 46
11.03.2022, 17:31  [ТС] 14
СУПЕР! Спасибо огромное...работает на ура!

работает быстро и в том файле где есть те самые другие диапазоны и Вы правы у тех диапазонов имен не было.

Очень, очень помогли, СПАСИБО!...а то мучаюсь с этим макросом 3й день.

Добавлено через 7 минут
Еще подскажите такой момент если в Общей спецификации (левая таблица) в одной из строк есть формула ссылающаяся на значение из строк выше

условно
например есть поз. 1 кран ф15 - кол-во - 7 шт.

Ниже есть строка поз. 155 резьба ф15 - кол-во 2х7=14 (где 7 - это кол-во из поз.1)

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

я так понимаю использовать формулы в Общей таблице - не желательно или есть способ обойти эту проблему?

Добавлено через 6 минут
В идеале конечно хотелось бы использовать формулы в левой части таблицы ОБЩАЯ, а в правую СВОДНУЮ переносить только текст (то как отображается в левой) с поддержкой форматирования (цвет, выделение)

Добавлено через 11 минут
Но даже без возможности использовать формулы - работает отлично, СУПЕР!
Тестил при разных условиях - глюков не обнаружил (кроме переноса ячеек с формулами)
0
0 / 0 / 0
Регистрация: 19.12.2019
Сообщений: 46
12.03.2022, 16:46  [ТС] 15
И все же обнаружились некоторые странности в работе макроса

1. Если вся строка в левой части таблицы пустая (в т.ч. критерий кол-во) - макрос все равно переносит строку в правую таблицу
2. Если есть текст в столбце Наименование, но в графе кол-во - пусто - макрос все равно переносит строку в правую таблицу
я для таких строк предполагал следующее в графе Кол-во сделать формулу - что то типа:
- если сумма значений раздела больше 0 то в графе Кол-во символ ="пробел" и тогда раздел отобразиться в правой части
- если сумма значений раздела меньше 0 то в графе символ ="" и тогда раздел НЕ отобразиться в правой части сводн.табл

Но это наверно возможно только если макрос сможет читать результат формул как текст а не переносить сами формулы как сейчас???

в принципе есть и проблема с переносом формул...но это удалось решить изменив пути исходных значений в формуле на абсолютные
0
552 / 482 / 191
Регистрация: 11.12.2013
Сообщений: 2,500
12.03.2022, 16:59 16
Пустую строку вставлял специально т.к. считал что это разделитель одного типа оборудования от другого, это легко уберу.
0
0 / 0 / 0
Регистрация: 19.12.2019
Сообщений: 46
12.03.2022, 17:48  [ТС] 17
я так и подумал, но иногда она вставляется без какой либо логики...
проще в левой таблице в нужной для отображения пустой строке в кол-во проставить пробел и она отобразиться в сводной, но может так как есть и не хуже.

Просто бывает (к примеру берем) раздел Демонтажные работы
а он пустой - ни чего не демонтируется ( везде кол-во ="") и в сводной ни чего не отобразиться кроме Демонтажные работы - они отобразятся да же если кол-во в этой строке ="".

Стоит ли усложнять макрос? если медленнее будет работать (не вижу смысла - лучше так) - тут же наверно придется что то придумывать что бы макрос смотрел не формулу, а результат, но как тогда сохранить форматирование результата (это мои мысли/размышления не специалиста)

По сути просто проскакивают несколько лишних не заполненных разделов в сводной таблице и иногда несколько пустых строк.

Добавлено через 4 минуты
В любом случае и в таком виде макрос работает шикарно!!! спасибо
0
малоболт
1324 / 507 / 212
Регистрация: 30.01.2020
Сообщений: 1,230
12.03.2022, 18:18 18
Лучший ответ Сообщение было отмечено ceatv как решение

Решение

ceatv, Вот макрос, который по идее должен чистить формулы в 15 колонке в процессе переноса.
Visual Basic
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
Sub Nik035()
 Dim nRows, rw, sh1, cnt, iBegin, aa
 Set sh1 = ActiveSheet 'Можно использовать Sheets("ИмяВашегоЛиста")
 nRows = sh1.Cells(sh1.Rows.Count, 13).End(-4162).Row - 3 'число непустых строк результата (без заголовка)
 sh1.Cells(4, 12).Resize(nRows, 6).ClearContents 'чистим прежний результат
 nRows = sh1.Cells(sh1.Rows.Count, 4).End(-4162).Row - 3 'число непустых строк исходника (без заголовка)
 aa = sh1.Cells(4, 3).Resize(nRows, 6).Value 'читаем исходник в массив для ускорения
 cnt = 4 'начальная строка результата
 iBegin = 0 'предыдущая непустая строка исходника (ниже заголовка)
 For rw = 1 To nRows Step 1 'перебираем строки
   If Trim(Cstr(aa(rw, 4))) = "" Then 'если значения нет
     If iBegin <> 0 Then 'если есть что переносить выше
       sh1.Cells(iBegin + 3, 3).Resize(rw - iBegin, 6).Copy sh1.Cells(cnt, 12) 'копирование ячеек в сводную спецификацию
       sh1.Cells(cnt, 15).Resize(rw - iBegin, 1).Value = aa 'копирование значений поверх, чтобы затереть формулы
       cnt = cnt + rw - iBegin 'сдвигаем начальную строку результата для следующего переноса
       iBegin = 0 'очищаем первую непустую строку исходника
     End If
   Else 'Значение есть (пусть даже и скрытое)
     If iBegin = 0 Then iBegin = rw 'установим начальную строку исходника для следующего переноса
     aa(rw - iBegin + 1, 1) = aa(rw, 4) 'перенсём значение в начало массива, чтобы потом затирать этим куском
   End If
 Next
 If iBegin <> 0 Then 'есть ещё последний непустой кусок для переноса
   sh1.Cells(iBegin + 3, 3).Resize(nRows - iBegin+1, 6).Copy sh1.Cells(cnt, 12) ' перенесем и его
   sh1.Cells(cnt, 15).Resize(nRows - iBegin+1, 1).Value = aa 'и затрём формулы значениями
 end if
 MsgBox "TheEnd!!!"
End Sub
Цитата Сообщение от ceatv Посмотреть сообщение
о сути просто проскакивают несколько лишних не заполненных разделов в сводной таблице и иногда несколько пустых строк.
У вас в 30 и 38 строке стоит невидимое значение = 1. Соответственно эта строка переносится якобы пустой, а на самом деле там значение есть.
1
0 / 0 / 0
Регистрация: 19.12.2019
Сообщений: 46
12.03.2022, 19:25  [ТС] 19
Вроде как все хорошо...макрос чуть медленнее предыдущего, но результат значительно лучше...особенно в плане формул, теперь левую часть таблицы можно автоматизировать.

Спасибо ОГРОМНОЕ!
и извините что отвлекаю в выходной.
0
малоболт
1324 / 507 / 212
Регистрация: 30.01.2020
Сообщений: 1,230
12.03.2022, 19:30 20
Забыл вставить Application.ScreenUpdating = False в начале и его же = True в конце.
Если вставить самостоятельно - макрос ускорится.
0
12.03.2022, 19:30
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
12.03.2022, 19:30
Помогаю со студенческими работами здесь

Макрос копирования данных из одной книги в другую
Доброго времени суток форумчане. Пытаюсь создать кнопку при нажатии на нее копируются данные из...

Макрос для добавления нужных строк из одной таблицы в другую
Добрый день! Я полный новичок в написании макросов, и мне крайне необходима помощь.. Ситуация:...

Написать макрос для переноса данных из одной таблицы в другую по кнопке
Здравствуйте, стоит задача по созданию базы данных по продажам для маленького бизнеса, выбор пал на...

Макрос переноса информации с одной страницы на другую
Нужен макрос переноса данных с одной страницы на вторую, в заданом формате, пример...

Макрос для копирования по условию
Здравствуйте! Помогите пожалуйста, если в столбце &quot;Выписка&quot; тогда эта строка должна скопирован в...

Формирование SQL запроса копирования полей из одной таблицы в другую
Всем привет! Не могу родить SQL-запрос. В базе sst.mdb есть таблицы SST и nSST. Нужно из SST в...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
20
Ответ Создать тему
КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin
Copyright ©2000 - 2024, CyberForum.ru