Excel распределение данных по листам
Разнести:
- Все данные - при выборе будет произведено разнесение абсолютно всех данных, расположенных на листе.
- Указанный диапазон - будут разнесены только те данные, которые расположены внутри указанного диапазона. Диапазон следует указывать без заголовка. Иначе заголовок будет определен как отдельный критерий и для него будет так же создан свой лист/книга.
Критерии:
- На основании значений - разнесение данных происходит на основании значений в ячейках. На рисунках выше таблица разносится именно на основании значений и в качестве столбца с критериями указан столбец с фамилиями руководителей. Это значит, что после выполнения команды будет создана новая книга, содержащая ровно столько листов, сколько руководителей в таблице. И в каждом листе будут содержаться только те сотрудники, которые работают в отделе, подчиненном данному руководителю.
- На основании цвета заливки - разнесение данных происходит на основании цвета заливки ячеек. В данном случае новым листам/книгам будет присвоено имя, равное числовому коду цвета заливки ячеек, а цвет ярлыков листов - равен цвету заливки ячеек.
- На основании цвета шрифта - разнесение данных происходит на основании цвета шрифта. В данном случае новым листам/книгам будет присвоено имя, равное числовому коду цвета шрифта, а цвет ярлыков листов - равен цвету шрифта.
- На фиксированное количество строк - данные будут разнесены пропорционально указанному количеству строк в окне напротив данной опции. Будут созданы листы/книги, количество строк с данными в которых будет равно указанному. При этом имена книг и листов будут называться диапазонами строк. Например, если выбрать разбиение диапазона по 10 строк, то результирующие листы или книги будут названы: 1-10 , 11-20 , 21-30 и т.д.
Поместить:
-
На разные листы одной книги - данные будут разнесены на разные листы одной книги. Книга создается в процессе выполнения команды. Количество листов соответствует количеству уникальных значений для разнесения. Имя каждого листа соответствует значению критерия, данные по которому занесены в этот лист. Если в качестве критерия выбрано На основании цвета заливки или На основании цвета шрифта, то именем листов будут числовые коды цвета заливки или шрифта ячеек.
Примечание: если в значении критерия имеются символы, недопустимые в имени листа( :/?*[] ), то эти символы удаляются. Если критерий содержит исключительно запрещенные символы, то они все будут удалены, а лист, на который будут помещены такие данные будет назван "_invalid_chars_" .
Если количество символов в значении превышает 30(максимально допустимое количество символов в имени листа - 31), то значение обрезается до 30 символов.
Примечание: если в значении критерия имеются символы, недопустимые в имени книги( :/?*"<>| ), то эти символы удаляются. Если критерий содержит исключительно запрещенные символы, то они все будут удалены, а книга, на которую будут помещены такие данные будет названа "_invalid_chars_".
Если количество символов в значении превышает 30, то значение обрезается до 30 символов(для большей "удобочитаемости", а так же для предотвращения ошибки, возникающей при длине пути к файлу, превышающей корректное определение файла операционной системой).
Номер столбца с критериями разнесения - указывается номер столбца, в котором расположены значения критериев для разнесения. Если на вкладке Основные выбрано Все данные - указывается номер столбца на листе. Т.е. если таблица данных расположена в диапазоне C3:G20 и критерии расположены в столбце D , то следует указать номер столбца 4 . Если на вкладке Основные выбрано Указанный диапазон, то указывается номер столбца внутри выбранного диапазона. Т.е. если указан диапазон C3:G20 и критерии расположены в столбце D , то следует указать номер столбца 2 .
Копировать заголовок на каждый лист - в новые листы/книги будет скопирован диапазон ячеек, указанный в поле. Диапазон для заголовков может быть расположен на любом листе любой открытой книги, а не обязательно на листе со значениями для разнесения. Рекомендуется указывать диапазон, ячейки самой нижней строки которого заполнены полностью. Это необходимо для корректного определения конца заголовка программой при вставке строк данных на лист.
Отправлять создаваемые листы/книги - если установлен, то созданные листы/книги будут отправлены на указанные адреса e-mail. Адреса могут быть указаны как в самой таблице для разнесения, так и отдельным списком соответствия.
- Брать адреса e-mail из столбца - указывается номер столбца. Если на вкладке Основные выбрано Все данные, то указывается номер столбца на листе, даже если сами данные для разнесения начинаются с 3 или любого другого столбца. Т.е. если таблица данных расположена в диапазоне C3:G20 и адреса e-mail при этом расположены в столбце G , то следует указать номер столбца 7 . Если на вкладке Основные выбрано Указанный диапазон, то указывается номер столбца внутри выбранного диапазона. Т.е. если указан диапазон C3:G20 и адреса e-mail при этом расположены в столбце G , то следует указать номер столбца 5 .
В данном случае необходимо, чтобы в самой таблице для разнесения присутствовал столбец с корректными адресами e-mail, на которые необходимо отправлять созданные файлы. При этом необязательно указывать e-mail для каждой строки - достаточно, если e-mail будет записан один раз для каждого критерия. - Адреса по списку соответствия - при выборе данного пункта необходимо заранее подготовить список соответствия адресов e-mail критериям в таблице. На примере таблицы выше список может выглядеть так:
При этом критерии и сами адреса e-mail должны располагаться в двух смежных столбцах: слева критерии, справа - адреса. На примере таблиц выше это столбцы B и C. Т.к. в качестве критерия разнесения на вкладке Основные выбраны были ФИО руководителя из столбца Руководитель, то в качестве списка соответствия необходимо указать диапазон B2:C5 .
Отправка - в этом блоке указывается способ отправки файлов и тема письма.
Тема письма - произвольный текст, который будет указан в создаваемых письмах в качестве темы. Если не указан, то в качестве темы каждого письма будет имя отправляемого файла.
Пользователь - имя пользователя. Как правило совпадает с учетной записью для входа в почту.
Пароль - пароль для входа в почту.
Порт - порт сервера SMTP. У большинства равен 25 или 465. Точное значения порта можно узнать только на самом сервере. Большинство из них размещают информацию по подключению почтовых программ к серверу, откуда можно узнать точные данные.
В Microsoft Excel есть много инструментов для сборки данных из нескольких таблиц (с разных листов или из разных файлов): прямые ссылки, функция ДВССЫЛ (INDIRECT) , надстройки Power Query и Power Pivot и т.д. С этой стороны баррикад всё выглядит неплохо.
Но если вы нарвётесь на обратную задачу - разнесения данных из одной таблицы на разные листы - то всё будет гораздо печальнее. На сегодняшний момент цивилизованных встроенных инструментов для такого разделения данных в арсенале Excel, к сожалению, нет. Так что придется задействовать макрос на Visual Basic, либо воспольоваться связкой макрорекордер+Power Query с небольшой "доработкой напильником" после.
Давайте подробно рассмотрим, как это можно реализовать.
Постановка задачи
Имеем в качестве исходных данных вот такую таблицу размером больше 5000 строк по продажам:
Задача: разнести данные из этой таблицы по городам на отдельные листы этой книги. Т.е. на выходе нужно получить на каждом листе только те строки из таблицы, где продажа была в соответствующем городе:
Подготовка
Чтобы не усложнять код макроса и сделать его максимально простым для понимания, выполним пару подготовительных действий.
Во-первых, создадим отдельную таблицу-справочник, где в единственном столбце будут перечислены все города, для которых нужно создать отдельные листы. Само-собой, в этом справочнике могут быть не все города, присутствующие в исходных данных, а только те, по которым нам нужны отчеты. Проще всего создать такую таблицу, используя команду Данные - Удалить дубликаты (Data - Remove duplicates) для копии столбца Город или функцию УНИК (UNIQUE) - если у вас последняя версия Excel 365.
Поскольку новые листы в Excel по умолчанию создаются перед (левее) текущего (предыдущего), то имеет смысл также отсортировать города в этом справочнике по убыванию (от Я до А) - тогда после создания листы-города расположатся по алфавиту.
Во-вторых, преобразуем обе таблицы в динамические ("умные"), чтобы с ними было проще работать. Используем команду Главная - Форматировать как таблицу (Home - Format as Table) или сочетание клавиш Ctrl + T . На появившейся вкладке Конструктор (Design) назовём их таблПродажи и таблГорода, соответственно:
Способ 1. Макрос для деления по листам
На вкладке Разработчик (Developer) нажмите на кнопку Visual Basic или используйте сочетание клавиш Alt + F11 . В открывшемся окне редактора макросов вставьте новый пустой модуль через меню Insert - Module и скопируйте туда следующий код:
Здесь с помощью цикла For Each . Next реализован проход по ячейкам справочника таблГорода, где для каждого города происходит его фильтрация (метод AutoFilter) в исходной таблице продаж и затем копирование результатов на новый созданный лист. Попутно созданный лист переименовывается в то же имя города и на нем включается автоподбор ширины столбцов для красоты.
Запустить созданный макрос в Excel можно на вкладке Разработчик кнопкой Макросы (Developer - Macros) или сочетанием клавиш Alt + F8 .
Способ 2. Создаем множественные запросы в Power Query
У предыдущего способа, при всей его компактности и простоте, есть существенный недостаток - созданные макросом листы не обновляются при изменениях в исходной таблице продаж. Если обновление "на лету" необходимо, то придется использовать связку VBA+Power Query, а точнее - создавать с помощью макроса не просто листы со статическими данными, а обновляемые запросы Power Query.
Макрос в этом случае частично похож на предыдущий (в нём тоже есть цикл For Each . Next для перебора городов в справочнике), но внутри цикла будет уже не фильтрация и копирование, а создание запроса Power Query и выгрузка его результатов на новый лист:
После его запуска мы увидим те же листы по городам, но формировать их будут уже созданные запросы Power Query:
При любых изменениях в исходных данных достаточно будет обновить соответствующую таблицу правой кнопкой мыши - команда Обновить (Refresh) или обновить сразу все города оптом, используя кнопку Обновить всё на вкладке Данные (Data - Refresh All) .
Vselennaya, у вас в каждом выложенном файле все время разные данные: то
Итого по хозяйственному
Итого по обычному, а в последнем файле уже
ИТОГО по ло-ву
Вы не могли бы прийти к единой терминологии.
Дальше, если у вас номера могут быть с начальным нулем, например 0738А, то вы говорили,
что в имени листа этого нуля не будет, но я вижу, что есть лист 0738. (Я полагал, что будет 738)
На листах с именем номера вагона шапка B14:N14 уже существует? Почему-то на некоторых листах ее нет.
И, главное, не могли бы вы отвечать быстрее на мои вопросы.
Vselennaya, у вас в каждом выложенном файле все время разные данные: то
Итого по хозяйственному
Итого по обычному, а в последнем файле уже
ИТОГО по ло-ву
Вы не могли бы прийти к единой терминологии.
Дальше, если у вас номера могут быть с начальным нулем, например 0738А, то вы говорили,
что в имени листа этого нуля не будет, но я вижу, что есть лист 0738. (Я полагал, что будет 738)
На листах с именем номера вагона шапка B14:N14 уже существует? Почему-то на некоторых листах ее нет.
И, главное, не могли бы вы отвечать быстрее на мои вопросы. Kuzmich
Kuzmich, нет там шапки, где не проставляет данные. Естественно, я и шапки расставлю. Там сотни номеров будет и вкладок в итоге. С нулями это назвала листы, чтобы посмотреть расставит макрос данные или нет. Увы не расставил. По поводу формулировки Итого, простите не знала, что имеет значение. ИТОГО по ло-ву должно быть. Как в последнем.
Стараюсь отвечать как можно быстрее. Очень отвлекают другими рабочими вопросами. Извините
Kuzmich, нет там шапки, где не проставляет данные. Естественно, я и шапки расставлю. Там сотни номеров будет и вкладок в итоге. С нулями это назвала листы, чтобы посмотреть расставит макрос данные или нет. Увы не расставил. По поводу формулировки Итого, простите не знала, что имеет значение. ИТОГО по ло-ву должно быть. Как в последнем.
Стараюсь отвечать как можно быстрее. Очень отвлекают другими рабочими вопросами. Извините Vselennaya
На листах с именем номера вагона шапка B14:N14 должна быть всегда,
макрос ориентируется на эту строку
Для вашего последнего примера
Sub iNomer()
Dim iNumber As String
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundCell As Range
Dim FAdr As String
Dim FAdr_Row As Long
Dim EAdr_Row As Long
Dim n As Integer
With CreateObject("scripting.dictionary"): .comparemode = 1
n = 15
iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
Range("S15:S" & Cells(Rows.Count, "S").End(xlUp).Row).ClearContents
For i = 15 To iLastRow 'выделяем из столбца C уникальные номера
If Cells(i, "C") <> "" Then
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "\d+"
iNumber = .Execute(Cells(i, "C"))(0)
End With
'If Not .exists(Left(Cells(i, "C").Value, 3)) Then
If Not .exists(iNumber) Then
'если нет слова, то добавляем его в словарь и в столбец S
.Add iNumber, 1
Cells(n, "S").NumberFormat = "@" 'текстовый формат ячейки
Cells(n, "S") = iNumber
n = n + 1
End If
End If
Next
End With
iLastRow = Cells(Rows.Count, "S").End(xlUp).Row
For i = 15 To iLastRow 'цикл по уникальным номерам в S
Set FoundCell = Columns(3).Find(Cells(i, "S"), , xlValues, xlPart)
If Not FoundCell Is Nothing Then
FAdr = FoundCell.Address
FAdr_Row = FoundCell.Row 'первая строка с уникальным номером
Do
EAdr_Row = FoundCell.Row 'последняя строка с уникальным номером
Set FoundCell = Columns(3).FindNext(FoundCell)
Loop While FoundCell.Address <> FAdr
End If
With Worksheets(CStr(Cells(i, "S")))
'очищаем диапазон на соответствующем листе
.Range("B15:N" & .Cells(.Rows.Count, "B").End(xlUp).Row + 1).Clear
'копируем диапазон от первой до последней строки + 1 уникального номера
'чтобы захватить строку с ИТОГО по ко-ву
Range("B" & FAdr_Row & ":N" & EAdr_Row + 1).Copy .Range("B15")
iLR = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range("B" & iLR + 2) = "Всего"
.Range("D" & iLR + 2) = Application.Sum(.Range("D15:D" & iLR))
.Range("E" & iLR + 2) = Application.Sum(.Range("E15:E" & iLR))
.Range("F" & iLR + 2) = Application.Sum(.Range("F15:F" & iLR))
.Range("N" & iLR + 2) = Application.Sum(.Range("N15:N" & iLR))
.Range("B" & iLR + 4) = "Период формирования акта от: " & Cells(FAdr_Row, "G") & _
" до " & Cells(EAdr_Row, "G")
For n = iLR To 15 Step -1 'удаляем строки на соответствующем листе с ИТОГО
If .Cells(n, "B") Like "ИТОГО*" Then
.Rows(n).Delete
End If
Next
End With
Next
End Sub
Привел пример формирования строки под таблицей "Период формирования акта от: "
Используйте этот принцип для своей шапки под таблицей
На листах с именем номера вагона шапка B14:N14 должна быть всегда,
макрос ориентируется на эту строку
Для вашего последнего примера
Sub iNomer()
Dim iNumber As String
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundCell As Range
Dim FAdr As String
Dim FAdr_Row As Long
Dim EAdr_Row As Long
Dim n As Integer
With CreateObject("scripting.dictionary"): .comparemode = 1
n = 15
iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
Range("S15:S" & Cells(Rows.Count, "S").End(xlUp).Row).ClearContents
For i = 15 To iLastRow 'выделяем из столбца C уникальные номера
If Cells(i, "C") <> "" Then
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "\d+"
iNumber = .Execute(Cells(i, "C"))(0)
End With
'If Not .exists(Left(Cells(i, "C").Value, 3)) Then
If Not .exists(iNumber) Then
'если нет слова, то добавляем его в словарь и в столбец S
.Add iNumber, 1
Cells(n, "S").NumberFormat = "@" 'текстовый формат ячейки
Cells(n, "S") = iNumber
n = n + 1
End If
End If
Next
End With
iLastRow = Cells(Rows.Count, "S").End(xlUp).Row
For i = 15 To iLastRow 'цикл по уникальным номерам в S
Set FoundCell = Columns(3).Find(Cells(i, "S"), , xlValues, xlPart)
If Not FoundCell Is Nothing Then
FAdr = FoundCell.Address
FAdr_Row = FoundCell.Row 'первая строка с уникальным номером
Do
EAdr_Row = FoundCell.Row 'последняя строка с уникальным номером
Set FoundCell = Columns(3).FindNext(FoundCell)
Loop While FoundCell.Address <> FAdr
End If
With Worksheets(CStr(Cells(i, "S")))
'очищаем диапазон на соответствующем листе
.Range("B15:N" & .Cells(.Rows.Count, "B").End(xlUp).Row + 1).Clear
'копируем диапазон от первой до последней строки + 1 уникального номера
'чтобы захватить строку с ИТОГО по ко-ву
Range("B" & FAdr_Row & ":N" & EAdr_Row + 1).Copy .Range("B15")
iLR = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range("B" & iLR + 2) = "Всего"
.Range("D" & iLR + 2) = Application.Sum(.Range("D15:D" & iLR))
.Range("E" & iLR + 2) = Application.Sum(.Range("E15:E" & iLR))
.Range("F" & iLR + 2) = Application.Sum(.Range("F15:F" & iLR))
.Range("N" & iLR + 2) = Application.Sum(.Range("N15:N" & iLR))
.Range("B" & iLR + 4) = "Период формирования акта от: " & Cells(FAdr_Row, "G") & _
" до " & Cells(EAdr_Row, "G")
For n = iLR To 15 Step -1 'удаляем строки на соответствующем листе с ИТОГО
If .Cells(n, "B") Like "ИТОГО*" Then
.Rows(n).Delete
End If
Next
End With
Next
End Sub
Привел пример формирования строки под таблицей "Период формирования акта от: "
Используйте этот принцип для своей шапки под таблицей Kuzmich
Sub iNomer()
Dim iNumber As String
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundCell As Range
Dim FAdr As String
Dim FAdr_Row As Long
Dim EAdr_Row As Long
Dim n As Integer
With CreateObject("scripting.dictionary"): .comparemode = 1
n = 15
iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
Range("S15:S" & Cells(Rows.Count, "S").End(xlUp).Row).ClearContents
For i = 15 To iLastRow 'выделяем из столбца C уникальные номера
If Cells(i, "C") <> "" Then
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "\d+"
iNumber = .Execute(Cells(i, "C"))(0)
End With
'If Not .exists(Left(Cells(i, "C").Value, 3)) Then
If Not .exists(iNumber) Then
'если нет слова, то добавляем его в словарь и в столбец S
.Add iNumber, 1
Cells(n, "S").NumberFormat = "@" 'текстовый формат ячейки
Cells(n, "S") = iNumber
n = n + 1
End If
End If
Next
End With
iLastRow = Cells(Rows.Count, "S").End(xlUp).Row
For i = 15 To iLastRow 'цикл по уникальным номерам в S
Set FoundCell = Columns(3).Find(Cells(i, "S"), , xlValues, xlPart)
If Not FoundCell Is Nothing Then
FAdr = FoundCell.Address
FAdr_Row = FoundCell.Row 'первая строка с уникальным номером
Do
EAdr_Row = FoundCell.Row 'последняя строка с уникальным номером
Set FoundCell = Columns(3).FindNext(FoundCell)
Loop While FoundCell.Address <> FAdr
End If
With Worksheets(CStr(Cells(i, "S")))
'очищаем диапазон на соответствующем листе
.Range("B15:N" & .Cells(.Rows.Count, "B").End(xlUp).Row + 1).Clear
'копируем диапазон от первой до последней строки + 1 уникального номера
'чтобы захватить строку с ИТОГО по ко-ву
Range("B" & FAdr_Row & ":N" & EAdr_Row + 1).Copy .Range("B15")
iLR = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range("B" & iLR + 2) = "Всего"
.Range("D" & iLR + 2) = Application.Sum(.Range("D15:D" & iLR))
.Range("E" & iLR + 2) = Application.Sum(.Range("E15:E" & iLR))
.Range("F" & iLR + 2) = Application.Sum(.Range("F15:F" & iLR))
.Range("N" & iLR + 2) = Application.Sum(.Range("N15:N" & iLR))
.Range("B" & iLR + 4) = "Период формирования акта от: " & Cells(FAdr_Row, "G") & _
" до " & Cells(EAdr_Row, "G")
For n = iLR To 15 Step -1 'удаляем строки на соответствующем листе с ИТОГО
If .Cells(n, "B") Like "ИТОГО*" Then
.Rows(n).Delete
End If
Next
End With
Next
End Sub
Привел пример формирования строки под таблицей "Период формирования акта от: "
Используйте этот принцип для своей шапки под таблицей Автор - Kuzmich
Дата добавления - 19.06.2018 в 16:23
Kuzmich, СПАСИБО огромное. Последние я надеюсь вопросы. А как сделать заливку строки ВСЕГО на каждом листе и продлить таблицу до этой строки?!
И как заполнить нижнюю шапку именно текст я поняла. А можно просто чтоб в каждом листе она была вставлена так же как верхняя шапка таблицы и просто смещалась соответственно формированию таблицы вниз? В примере цветными вкладками выделила как должно быть и откуда данные берутся. Вот данные я буду сама вставлять и они будут в шапочку верхнюю и нижнюю переноситься. И просто надо чтою смещалась вниз шапка нижняя. Единственное одна цифра будет в саму таблицу проставляться из данных для шапки . Как сделать так, чтобы они проставлялись в таблицу макросом сформированную?
Kuzmich, СПАСИБО огромное. Последние я надеюсь вопросы. А как сделать заливку строки ВСЕГО на каждом листе и продлить таблицу до этой строки?!
И как заполнить нижнюю шапку именно текст я поняла. А можно просто чтоб в каждом листе она была вставлена так же как верхняя шапка таблицы и просто смещалась соответственно формированию таблицы вниз? В примере цветными вкладками выделила как должно быть и откуда данные берутся. Вот данные я буду сама вставлять и они будут в шапочку верхнюю и нижнюю переноситься. И просто надо чтою смещалась вниз шапка нижняя. Единственное одна цифра будет в саму таблицу проставляться из данных для шапки . Как сделать так, чтобы они проставлялись в таблицу макросом сформированную? Vselennaya
Здравствуйте! Очень прошу вашей помощи. Моих познаний в Excel оказалось недостаточно для поставленной задачи. Есть файл сводный. Надо раскидать данный файла по листам книги согласно названию листа. Уже руками каждый месяц сил нету это делать. Может есть формула или с написанием макроса поможете. Буду рада любой информации.
Здравствуйте! Очень прошу вашей помощи. Моих познаний в Excel оказалось недостаточно для поставленной задачи. Есть файл сводный. Надо раскидать данный файла по листам книги согласно названию листа. Уже руками каждый месяц сил нету это делать. Может есть формула или с написанием макроса поможете. Буду рада любой информации. Vselennaya
Это одноразово или подразумевается, что на исходном листе потом могут новые данные появиться? StoTisteg
Public Лист As String
Public Строка As Long, Итого(1 To 3) As Long
Dim Шапка As Range
Dim i As Long
Лист = "qwe"
With Worksheets(1)
Set Шапка = .Range(.Cells(14, 2), .Cells(14, 16))
For i = 15 To .Cells(Rows.Count, 6).End(xlUp).Row
If InStr(1, .Cells(i, 4).Value, Лист, vbTextCompare) = 1 And .Cells(i, 4).Value <> "" Then
.Rows(i).Copy Destination:=Worksheets(Лист & "").Rows(Строка)
Строка = Строка + 1
Else
If .Cells(i, 4).Value <> "" Then
If Лист <> "qwe" Then Call Оформление
Лист = IIf(IsNumeric(.Cells(i, 4).Value), .Cells(i, 4).Value, Left(.Cells(i, 4).Value, Len(.Cells(i, 4).Value) - 1))
Worksheets.Add after:=Worksheets(Sheets.Count)
ActiveSheet.Name = Лист
Шапка.Copy Destination:=Cells(14, 2)
With Cells(14, 17)
.Value = "Кол-во( суммарно)"
.Orientation = 90
Cells(14, 16).Copy
.PasteSpecial Paste:=xlPasteFormats
End With
.Rows(i).Copy Destination:=Worksheets(Лист & "").Rows(15)
Строка = 16
Итого(1) = 0
Итого(2) = 0
Итого(3) = 0
Else
If .Cells(i, 2) = "Итого по обычному" Then
Итого(1) = Итого(1) + .Cells(i, 6).Value
Итого(2) = Итого(2) + .Cells(i, 7).Value
Итого(3) = Итого(3) + .Cells(i, 8).Value
End If
End If
End If
Next i
Call Оформление
End With
With Worksheets(Лист & "")
For j = 1 To 3
.Cells(Строка, j + 5).Value = Итого(j)
.Cells(Строка + 2, j + 5).Value = Итого(j)
Next j
.Cells(Строка, 2).Value = "Итого по обычному"
.Cells(Строка + 2, 2).Value = "Всего"
With Worksheets(1)
.Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 2).Copy
End With
.Range(.Cells(Строка + 2, 2), .Cells(Строка + 2, 17)).PasteSpecial Paste:=xlPasteFormats
With .Range(.Cells(14, 2), .Cells(Строка + 2, 17))
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeRight).Weight = xlThin
End With
For j = 15 To Строка - 1
.Cells(j, 2).Value = j - 14
Next j
End With
Public Лист As String
Public Строка As Long, Итого(1 To 3) As Long
Dim Шапка As Range
Dim i As Long
Лист = "qwe"
With Worksheets(1)
Set Шапка = .Range(.Cells(14, 2), .Cells(14, 16))
For i = 15 To .Cells(Rows.Count, 6).End(xlUp).Row
If InStr(1, .Cells(i, 4).Value, Лист, vbTextCompare) = 1 And .Cells(i, 4).Value <> "" Then
.Rows(i).Copy Destination:=Worksheets(Лист & "").Rows(Строка)
Строка = Строка + 1
Else
If .Cells(i, 4).Value <> "" Then
If Лист <> "qwe" Then Call Оформление
Лист = IIf(IsNumeric(.Cells(i, 4).Value), .Cells(i, 4).Value, Left(.Cells(i, 4).Value, Len(.Cells(i, 4).Value) - 1))
Worksheets.Add after:=Worksheets(Sheets.Count)
ActiveSheet.Name = Лист
Шапка.Copy Destination:=Cells(14, 2)
With Cells(14, 17)
.Value = "Кол-во( суммарно)"
.Orientation = 90
Cells(14, 16).Copy
.PasteSpecial Paste:=xlPasteFormats
End With
.Rows(i).Copy Destination:=Worksheets(Лист & "").Rows(15)
Строка = 16
Итого(1) = 0
Итого(2) = 0
Итого(3) = 0
Else
If .Cells(i, 2) = "Итого по обычному" Then
Итого(1) = Итого(1) + .Cells(i, 6).Value
Итого(2) = Итого(2) + .Cells(i, 7).Value
Итого(3) = Итого(3) + .Cells(i, 8).Value
End If
End If
End If
Next i
Call Оформление
End With
With Worksheets(Лист & "")
For j = 1 To 3
.Cells(Строка, j + 5).Value = Итого(j)
.Cells(Строка + 2, j + 5).Value = Итого(j)
Next j
.Cells(Строка, 2).Value = "Итого по обычному"
.Cells(Строка + 2, 2).Value = "Всего"
With Worksheets(1)
.Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 2).Copy
End With
.Range(.Cells(Строка + 2, 2), .Cells(Строка + 2, 17)).PasteSpecial Paste:=xlPasteFormats
With .Range(.Cells(14, 2), .Cells(Строка + 2, 17))
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeRight).Weight = xlThin
End With
For j = 15 To Строка - 1
.Cells(j, 2).Value = j - 14
Next j
End With
Интуитивно понятный код - это когда интуитивно понятно, что это код.
Public Лист As String
Public Строка As Long, Итого(1 To 3) As Long
Dim Шапка As Range
Dim i As Long
Лист = "qwe"
With Worksheets(1)
Set Шапка = .Range(.Cells(14, 2), .Cells(14, 16))
For i = 15 To .Cells(Rows.Count, 6).End(xlUp).Row
If InStr(1, .Cells(i, 4).Value, Лист, vbTextCompare) = 1 And .Cells(i, 4).Value <> "" Then
.Rows(i).Copy Destination:=Worksheets(Лист & "").Rows(Строка)
Строка = Строка + 1
Else
If .Cells(i, 4).Value <> "" Then
If Лист <> "qwe" Then Call Оформление
Лист = IIf(IsNumeric(.Cells(i, 4).Value), .Cells(i, 4).Value, Left(.Cells(i, 4).Value, Len(.Cells(i, 4).Value) - 1))
Worksheets.Add after:=Worksheets(Sheets.Count)
ActiveSheet.Name = Лист
Шапка.Copy Destination:=Cells(14, 2)
With Cells(14, 17)
.Value = "Кол-во( суммарно)"
.Orientation = 90
Cells(14, 16).Copy
.PasteSpecial Paste:=xlPasteFormats
End With
.Rows(i).Copy Destination:=Worksheets(Лист & "").Rows(15)
Строка = 16
Итого(1) = 0
Итого(2) = 0
Итого(3) = 0
Else
If .Cells(i, 2) = "Итого по обычному" Then
Итого(1) = Итого(1) + .Cells(i, 6).Value
Итого(2) = Итого(2) + .Cells(i, 7).Value
Итого(3) = Итого(3) + .Cells(i, 8).Value
End If
End If
End If
Next i
Call Оформление
End With
With Worksheets(Лист & "")
For j = 1 To 3
.Cells(Строка, j + 5).Value = Итого(j)
.Cells(Строка + 2, j + 5).Value = Итого(j)
Next j
.Cells(Строка, 2).Value = "Итого по обычному"
.Cells(Строка + 2, 2).Value = "Всего"
With Worksheets(1)
.Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 2).Copy
End With
.Range(.Cells(Строка + 2, 2), .Cells(Строка + 2, 17)).PasteSpecial Paste:=xlPasteFormats
With .Range(.Cells(14, 2), .Cells(Строка + 2, 17))
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeRight).Weight = xlThin
End With
For j = 15 To Строка - 1
.Cells(j, 2).Value = j - 14
Next j
End With
А номер в столбце D всегда состоит из трех цифр?
Что должно быть в столбце Q - Кол-во( суммарно)? Kuzmich
А номер в столбце D всегда состоит из трех цифр?
Что должно быть в столбце Q - Кол-во( суммарно)? Автор - Kuzmich
Дата добавления - 06.06.2018 в 17:36
Может ли быть ситуация, когда номер в столбце D есть, а соответствующего листа нет?
Нужно ли тогда создавать новый лист?
Может ли быть ситуация, когда номер в столбце D есть, а соответствующего листа нет?
Нужно ли тогда создавать новый лист? Kuzmich
StoTisteg, Спасибо большое! А подскажите , если форма таблицы поменялась и два столбца убрались, как сделать так чтоб макрос работал?
StoTisteg, Спасибо большое! А подскажите , если форма таблицы поменялась и два столбца убрались, как сделать так чтоб макрос работал? Vselennaya
Kuzmich, Да может и надо чтоб он создавал новые листы для новых номеров. В идеале надо чтоб я просто вставляла исходный файл, запускала макрос и он по листам раскидывал данные. Там еще после таблицы шапочка будет и над таблицей шапочка. Ещё бы ее заполнять. Там в шапочке номер указан будет (столбец D), а внизу в шапочку данные будут вставляться из таблицы тоже и из еще одной таблички с итоговыми значениями. Так вот вопрос возможно ли сделать так чтоб еще и шапочка заполнялась?
Kuzmich, Да может и надо чтоб он создавал новые листы для новых номеров. В идеале надо чтоб я просто вставляла исходный файл, запускала макрос и он по листам раскидывал данные. Там еще после таблицы шапочка будет и над таблицей шапочка. Ещё бы ее заполнять. Там в шапочке номер указан будет (столбец D), а внизу в шапочку данные будут вставляться из таблицы тоже и из еще одной таблички с итоговыми значениями. Так вот вопрос возможно ли сделать так чтоб еще и шапочка заполнялась? Vselennaya
StoTisteg, Новые данные будут каждый месяц добавляться и меняться. Номер из столбца D будет тот же, но будут новые добавляться номера с каждым месяцем
StoTisteg, Новые данные будут каждый месяц добавляться и меняться. Номер из столбца D будет тот же, но будут новые добавляться номера с каждым месяцем Vselennaya
StoTisteg, Это далеко не одноразовый код. Мне с этим годами теперь работать и данные буду только расти и увеличиваться.
StoTisteg, Это далеко не одноразовый код. Мне с этим годами теперь работать и данные буду только расти и увеличиваться. Vselennaya
А подскажите , если форма таблицы поменялась и два столбца убрались, как сделать так чтоб макрос работал?
А подскажите , если форма таблицы поменялась и два столбца убрались, как сделать так чтоб макрос работал?
А подскажите , если форма таблицы поменялась и два столбца убрались, как сделать так чтоб макрос работал?
Sub iNomer()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundCell As Range
Dim FAdr As String
Dim FAdr_Row As Long
Dim EAdr_Row As Long
Dim n As Integer
With CreateObject("scripting.dictionary"): .comparemode = 1
n = 15
iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
Range("S15:S" & Cells(Rows.Count, "S").End(xlUp).Row).ClearContents
For i = 15 To iLastRow 'выделяем из столбца C уникальные трехзначные номера
If Cells(i, "C") <> "" Then
If Not .exists(Left(Cells(i, "C").Value, 3)) Then
'если нет слова, то добавляем его в словарь и в столбец S
.Add Left(Cells(i, "C").Value, 3), 1
Cells(n, "S") = Left(Cells(i, "C").Value, 3)
n = n + 1
End If
End If
Next
End With
iLastRow = Cells(Rows.Count, "S").End(xlUp).Row
For i = 15 To iLastRow 'цикл по уникальным номерам в S
Set FoundCell = Columns(3).Find(Cells(i, "S"), , xlValues, xlPart)
If Not FoundCell Is Nothing Then
FAdr = FoundCell.Address
FAdr_Row = FoundCell.Row 'первая строка с уникальным номером
Do
EAdr_Row = FoundCell.Row 'последняя строка с уникальным номером
Set FoundCell = Columns(3).FindNext(FoundCell)
Loop While FoundCell.Address <> FAdr
End If
With Worksheets(CStr(Cells(i, "S")))
'очищаем диапазон на соответствующем листе
.Range("B15:N" & .Cells(.Rows.Count, "B").End(xlUp).Row + 1).Clear
'копируем диапазон от первой до последней строки + 2 уникального номера
Range("B" & FAdr_Row & ":N" & EAdr_Row + 2).Copy .Range("B15")
iLR = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range("B" & iLR + 1) = "Всего"
.Range("D" & iLR + 1) = Application.Sum(.Range("D15:D" & iLR))
.Range("E" & iLR + 1) = Application.Sum(.Range("E15:E" & iLR))
.Range("F" & iLR + 1) = Application.Sum(.Range("F15:F" & iLR))
.Range("N" & iLR + 1) = Application.Sum(.Range("N15:N" & iLR))
For n = iLR To 15 Step -1 'удаляем строки на соответствующем листе с Итого
If .Cells(n, "B") Like "Итого*" Then
.Rows(n).Delete
End If
Next
End With
Next
End Sub
Sub iNomer()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundCell As Range
Dim FAdr As String
Dim FAdr_Row As Long
Dim EAdr_Row As Long
Dim n As Integer
With CreateObject("scripting.dictionary"): .comparemode = 1
n = 15
iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
Range("S15:S" & Cells(Rows.Count, "S").End(xlUp).Row).ClearContents
For i = 15 To iLastRow 'выделяем из столбца C уникальные трехзначные номера
If Cells(i, "C") <> "" Then
If Not .exists(Left(Cells(i, "C").Value, 3)) Then
'если нет слова, то добавляем его в словарь и в столбец S
.Add Left(Cells(i, "C").Value, 3), 1
Cells(n, "S") = Left(Cells(i, "C").Value, 3)
n = n + 1
End If
End If
Next
End With
iLastRow = Cells(Rows.Count, "S").End(xlUp).Row
For i = 15 To iLastRow 'цикл по уникальным номерам в S
Set FoundCell = Columns(3).Find(Cells(i, "S"), , xlValues, xlPart)
If Not FoundCell Is Nothing Then
FAdr = FoundCell.Address
FAdr_Row = FoundCell.Row 'первая строка с уникальным номером
Do
EAdr_Row = FoundCell.Row 'последняя строка с уникальным номером
Set FoundCell = Columns(3).FindNext(FoundCell)
Loop While FoundCell.Address <> FAdr
End If
With Worksheets(CStr(Cells(i, "S")))
'очищаем диапазон на соответствующем листе
.Range("B15:N" & .Cells(.Rows.Count, "B").End(xlUp).Row + 1).Clear
'копируем диапазон от первой до последней строки + 2 уникального номера
Range("B" & FAdr_Row & ":N" & EAdr_Row + 2).Copy .Range("B15")
iLR = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range("B" & iLR + 1) = "Всего"
.Range("D" & iLR + 1) = Application.Sum(.Range("D15:D" & iLR))
.Range("E" & iLR + 1) = Application.Sum(.Range("E15:E" & iLR))
.Range("F" & iLR + 1) = Application.Sum(.Range("F15:F" & iLR))
.Range("N" & iLR + 1) = Application.Sum(.Range("N15:N" & iLR))
For n = iLR To 15 Step -1 'удаляем строки на соответствующем листе с Итого
If .Cells(n, "B") Like "Итого*" Then
.Rows(n).Delete
End If
Next
End With
Next
End Sub
Sub iNomer()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundCell As Range
Dim FAdr As String
Dim FAdr_Row As Long
Dim EAdr_Row As Long
Dim n As Integer
With CreateObject("scripting.dictionary"): .comparemode = 1
n = 15
iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
Range("S15:S" & Cells(Rows.Count, "S").End(xlUp).Row).ClearContents
For i = 15 To iLastRow 'выделяем из столбца C уникальные трехзначные номера
If Cells(i, "C") <> "" Then
If Not .exists(Left(Cells(i, "C").Value, 3)) Then
'если нет слова, то добавляем его в словарь и в столбец S
.Add Left(Cells(i, "C").Value, 3), 1
Cells(n, "S") = Left(Cells(i, "C").Value, 3)
n = n + 1
End If
End If
Next
End With
iLastRow = Cells(Rows.Count, "S").End(xlUp).Row
For i = 15 To iLastRow 'цикл по уникальным номерам в S
Set FoundCell = Columns(3).Find(Cells(i, "S"), , xlValues, xlPart)
If Not FoundCell Is Nothing Then
FAdr = FoundCell.Address
FAdr_Row = FoundCell.Row 'первая строка с уникальным номером
Do
EAdr_Row = FoundCell.Row 'последняя строка с уникальным номером
Set FoundCell = Columns(3).FindNext(FoundCell)
Loop While FoundCell.Address <> FAdr
End If
With Worksheets(CStr(Cells(i, "S")))
'очищаем диапазон на соответствующем листе
.Range("B15:N" & .Cells(.Rows.Count, "B").End(xlUp).Row + 1).Clear
'копируем диапазон от первой до последней строки + 2 уникального номера
Range("B" & FAdr_Row & ":N" & EAdr_Row + 2).Copy .Range("B15")
iLR = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range("B" & iLR + 1) = "Всего"
.Range("D" & iLR + 1) = Application.Sum(.Range("D15:D" & iLR))
.Range("E" & iLR + 1) = Application.Sum(.Range("E15:E" & iLR))
.Range("F" & iLR + 1) = Application.Sum(.Range("F15:F" & iLR))
.Range("N" & iLR + 1) = Application.Sum(.Range("N15:N" & iLR))
For n = iLR To 15 Step -1 'удаляем строки на соответствующем листе с Итого
If .Cells(n, "B") Like "Итого*" Then
.Rows(n).Delete
End If
Next
End With
Next
End Sub
Всем привет, помогите пожалуйста распределить данные из Листа "Расчёты" (от A6:D113) на листы: "Приложение №1-№4" в зависимости от Класса бетона и возраста. Но в дальнейшем это будет изменяться! Н-р: если В30 и возраст от 7 до 14 дней то в приложение 1, если В40 и возраст от 7 до 14 дней то в №2, если В30 и возраст больше 28 дней то в №3 и если В40 и возраст более 28 дней то в №4! Спасибо!
опять файл большой:
Простите
Всем привет, помогите пожалуйста распределить данные из Листа "Расчёты" (от A6:D113) на листы: "Приложение №1-№4" в зависимости от Класса бетона и возраста. Но в дальнейшем это будет изменяться! Н-р: если В30 и возраст от 7 до 14 дней то в приложение 1, если В40 и возраст от 7 до 14 дней то в №2, если В30 и возраст больше 28 дней то в №3 и если В40 и возраст более 28 дней то в №4! Спасибо!
опять файл большой:
Простите NIC
Нет 100% уверенности, что решение этой задачи нужно для дела, а не попадет в архив ненужных файлов.
Решение целесообразно делать макросом. Алгоритм примерно такой.
Внешний цикл по листам. Из имени листа извлекаем класс и возраст.
Внутренний цикл по по строкам кранных 6, начиная с шестой строки.
Оператор ЕСЛИ проверяет ячейки на совпадение класса И возраста в соответствующих ячейках.
Если совпадает, то копируется диапазон из 6 строк на лист из которого брали класс и возраст.
По окончании цикла по строкам листа "исх данные" переход к следующему листу по внешнему циклу.
В таблице не отражен возраст бетона от 1 до 7 дней, от 14 до 28
Чтобы придумать и использовать универсальный алгоритм извлечения класса и возраста из имени листа, желательно знать все классы и возможные диапазоны возрастов.
Нет 100% уверенности, что решение этой задачи нужно для дела, а не попадет в архив ненужных файлов.
Решение целесообразно делать макросом. Алгоритм примерно такой.
Внешний цикл по листам. Из имени листа извлекаем класс и возраст.
Внутренний цикл по по строкам кранных 6, начиная с шестой строки.
Оператор ЕСЛИ проверяет ячейки на совпадение класса И возраста в соответствующих ячейках.
Если совпадает, то копируется диапазон из 6 строк на лист из которого брали класс и возраст.
По окончании цикла по строкам листа "исх данные" переход к следующему листу по внешнему циклу.
В таблице не отражен возраст бетона от 1 до 7 дней, от 14 до 28
Чтобы придумать и использовать универсальный алгоритм извлечения класса и возраста из имени листа, желательно знать все классы и возможные диапазоны возрастов. AlexM
Читайте также: