Редизайнер таблиц
Не секрет, что большинство пользователей Excel, создавая таблицы на листах, думают в первую очередь о собственном комфорте и удобстве. Так рождаются на свет красивые, со сложными "шапками", пестрые и громоздкие таблицы, которые при этом совершенно нельзя ни отфильтровать, ни отсортировать, а про автоматический отчет сводной таблицей лучше и не думать вообще.
Рано или поздно пользователь такой таблицы приходит к мысли, что "пусть будет не так красиво, зато можно работать" и начинает упрощать дизайн своей таблицы, приводя его в соответствие с классическими рекомендациями:
- простая однострочная шапка, где у каждого столбца будет свое уникальное название (имя поля)
- одна строка - одна законченная операция (сделка, продажа, проводка, проект и т.д.)
- без объединенных ячеек
- без разрывов в виде пустых строк и столбцов
Но если сделать однострочную шапку из многоэтажной или разбить один столбец на несколько достаточно просто, то реконструирование таблицы может занять много времени (особенно при больших размерах ). Имеется ввиду следующая ситуация:
| Из |
|
сделать |
|
В терминах баз данных правую таблицу обычно называют плоской (flat) - именно по таким таблицам лучше всего строить отчеты сводных таблиц (pivot tables) и проводить аналитику.
Преобразовать двумерную таблицу в плоскую можно при помощи простого макроса. Откройте редактор Visual Basic через вкладку Разработчик - Visual Basic (Developer - Visual Basic Editor) или сочетанием клавиш Alt+F11. Вставьте новый модуль (Insert - Module) и скопируйте туда текст этого макроса:
Sub Redesigner()
Dim i As Long
Dim hc As Integer, hr As Integer
Dim ns As Worksheet
hr = InputBox("Сколько строк с подписями сверху?")
hc = InputBox("Сколько столбцов с подписями слева?")
Application.ScreenUpdating = False
i = 1
Set inpdata = Selection
Set ns = Worksheets.Add
For r = (hr + 1) To inpdata.Rows.Count
For c = (hc + 1) To inpdata.Columns.Count
For j = 1 To hc
ns.Cells(i, j) = inpdata.Cells(r, j)
Next j
For k = 1 To hr
ns.Cells(i, j + k - 1) = inpdata.Cells(k, c)
Next k
ns.Cells(i, j + k - 1) = inpdata.Cells(r, c)
i = i + 1
Next c
Next r
End Sub
После этого можно закрыть редактор VBA и вернуться в Excel. Теперь можно выделить исходную таблицу (полностью, с шапкой и первым столбцом с месяцами) и запустить наш макрос через Разработчик - Макросы (Developer - Macros) или нажав сочетание Alt+F8.
Макрос вставит в книгу новый лист и создаст на нем новый, реконструированный вариант выделенной таблицы. С такой таблицей можно работать "по полной программе", применяя весь арсенал средств Excel для обработки и анализа больших списков.
Ссылки по теме
- Что такое макросы, куда вставлять код макроса на VBA, как их использовать
- Создание отчетов с помощью сводных таблиц
- Инструмент для редизайна двумерных таблиц в плоские из надстройки PLEX
Чтобы из таблицы 2 (сделать) получилась 1 (из)..
Делюсь доработанным вариантом, сделанным для себя.
Подходит для случая, когда количество измерений по столбцам и строкам отличные от 1. Регулируется переменными RBorder (показателей в шапке по строкам) и CBorder (показателей в шапке по колонкам).
Sub Redesigner() Dim InVal As Variant Dim OutVal() As Variant Dim j, k, i, r, c As Long Dim NewSheet Dim RBorder, CBorder As Long RBorder = 1 CBorder = 2 i = 1 InVal = Selection.Formula ReDim OutVal(1 To Selection.Count, 1 To (RBorder + CBorder + 1)) For j = CBorder + 1 To UBound(InVal, 1) For k = RBorder + 1 To UBound(InVal, 2) If InVal(j, k) <> "" Then For r = 1 To RBorder If InVal(j, r) <> "" Then OutVal(i, r) = InVal(j, r) Else OutVal(i, r) = OutVal(i - 1, r) End If Next r For c = RBorder + 1 To RBorder + CBorder If InVal(c - RBorder, k) <> "" Then OutVal(i, c) = InVal(c - RBorder, k) Else OutVal(i, c) = OutVal(i - 1, c) End If Next c OutVal(i, RBorder + CBorder + 1) = InVal(j, k) i = i + 1 End If Next k Next j Set NewSheet = Worksheets.Add NewSheet.Range("A1").Resize(UBound(OutVal, 1), (RBorder + CBorder + 1)). Value = OutVal End SubЕсли же оставляю Только один из первых 3-х столбцов, тогда всё ок. Если будет время доработать данный макрос, было бы классно.
to 5700, а с Вашим макросом что-то не так, ругается на строку перед End Sub
Комментирую один нюанс использования этого макроса - первая ячейка исходной "неплоской" таблицы должна быть в ячейке A1, иначе макрос начинает добавлять пустые строки.
вот ссылка на скрин
Sub Redesigner() Dim inpdata As Range, realdata As Range, cell As Range Dim i As Long, c As Long, r As Long Dim hc As Long, hr As Long Dim ns As Worksheet hr = Val(InputBox("Сколько строк с подписями данных сверху")) hc = Val(InputBox("Сколько столбцов с подписями данных слева?")) Set inpdata = Selection If inpdata.Rows.Count <= hr Or inpdata.Columns.Count <= hc Then Exit Sub Set realdata = inpdata.Offset(hr, hc).Resize(inpdata.Rows.Count - hr, inpdata.Columns.Count - hc) Set ns = Worksheets.Add i = 1 For Each cell In realdata If cell.Value <> "" Then For c = 1 To hc ns.Cells(i, c) = inpdata.Cells(cell.Row - inpdata.Row + 1, c) Next c For r = 1 To hr ns.Cells(i, c + r - 1) = inpdata.Cells(r, cell.Column - inpdata.Column + 1) Next r ns.Cells(i, c + r - 1) = cell.Value i = i + 1 End If Next cell End SubSub Redesigner() Dim inpdata As Range, realdata As Range, ns As Worksheet Dim i&, j&, k&, c&, r&, hc&, hr& Dim out(), dataArr, hcArr, hrArr hr = Val(InputBox("Сколько строк с подписями данных сверху?")) hc = Val(InputBox("Сколько столбцов с подписями данных слева?")) Set inpdata = Selection If inpdata.Rows.Count <= hr Or inpdata.Columns.Count <= hc Then Exit Sub Set realdata = inpdata.Offset(hr, hc).Resize(inpdata.Rows.Count - hr, inpdata.Columns.Count - hc) dataArr = realdata.Value If hr Then hrArr = inpdata.Offset(0, hc).Resize(hr, inpdata.Columns.Count - hc).Value If hc Then hcArr = inpdata.Offset(hr, 0).Resize(inpdata.Rows.Count - hr, hc).Value ReDim out(1 To Application.CountA(realdata), 1 To hr + hc + 1) Set ns = Worksheets.Add For i = 1 To UBound(dataArr, 1) For j = 1 To UBound(dataArr, 2) If Not IsEmpty(dataArr(i, j)) Then k = k + 1 For c = 1 To hc: out(k, c) = hcArr(i, c): Next c For r = 1 To hr: out(k, c + r - 1) = hrArr(r, j): Next r out(k, c + r - 1) = dataArr(i, j) End If Next j, i ns.Cells(2, 1).Resize(UBound(out, 1), UBound(out, 2)) = out End SubЧто нужно изменить в макросе, чтобы в итоговой таблице были показаны все ячейки без потерь?
Итог - создает пустой лист и всё. Что надо сделать, чтобы работало, подскажите, пожалуйста!
Сейчас код таков:
Sub Redesigner() Dim inpdata As Range, realdata As Range, ns As Worksheet Dim i&, j&, k&, c&, r&, hc&, hr& Dim out(), dataArr, hcArr, hrArr hr = Val(InputBox("Ñêîëüêî ñòðîê ñ ïîäïèñÿìè äàííûõ ñâåðõó?")) hc = Val(InputBox("Ñêîëüêî ñòîëáöîâ ñ ïîäïèñÿìè äàííûõ ñëåâà?")) Set inpdata = Selection If inpdata.Rows.Count <= hr Or inpdata.Columns.Count <= hc Then Exit Sub Set realdata = inpdata.Offset(hr, hc).Resize(inpdata.Rows.Count - hr, inpdata.Columns.Count - hc) dataArr = realdata.Value If hr Then hrArr = inpdata.Offset(0, hc).Resize(hr, inpdata.Columns.Count - hc).Value If hc Then hcArr = inpdata.Offset(hr, 0).Resize(inpdata.Rows.Count - hr, hc).Value ReDim out(1 To realdata.Count, 1 To hr + hc + 1) 'ReDim out(1 To Application.CountA(realdata), 1 To hr + hc + 1) Set ns = Worksheets.Add For i = 1 To UBound(dataArr, 1) For j = 1 To UBound(dataArr, 2) 'If Not IsEmpty(dataArr(i, j)) Then ' k = k + 1 ' For c = 1 To hc: out(k, c) = hcArr(i, c): Next c ' For r = 1 To hr: out(k, c + r - 1) = hrArr(r, j): Next r ' out(k, c + r - 1) = dataArr(i, j) 'End If Next j, i ns.Cells(2, 1).Resize(UBound(out, 1), UBound(out, 2)) = out End Subуберите
Но теперь даже чистого листа нет. Просто ничего не происходит:(
Немного изменил его, вместо:
hr = Val(InputBox("Сколько строк с подписями данных сверху?")) hc = Val(InputBox("Сколько столбцов с подписями данных слева?")) Set inpdata = Selectionсделал
Set inpdata = ThisWorkbook.Application.InputBox( _ prompt:="Выберите обрабатываемый диапазон:", Title:="Выбор диапазона", Type:=8) hr = Val(InputBox("Сколько строк с подписями сверху?")) hc = Val(InputBox("Сколько столбцов с подписями слева?"))Так, мне кажется, удобнее: сначала даем юзеру возможность выбрать диапазон, затем уже спрашиваем, что является заголовками в том, что он выбрал.
PS. Выигрыш во времени по сравнению с оригинальным кодом с перебором ячеек (небольшая таблица 206x13):
ячейки = 6,617188
массив = 0,0625
Спасибо.
Теперь бы еще код разобрать...
Попробовала добавить, ппедложенную Вами команду:
Next r
ns.Cells(i, c + r - 1).NumberFormat = Text
ns.Cells(i, c + r - 1) = cell.Value
все равно не получается. Так 1/2 становится 02.янв (хотя по идее должно менять на 01.фев)...
Подскажите, пожалуйста, что не так, почему не срабатывает.
Спасибо
на
и все заработает.
Но имейте ввиду - все числовые значения станут текстом (т.е. с ними не будет работать математика).
Если выделить область значений и вставить в строки 2 в столбцы 3 получится результат, только пропадают цвета.
Кто-то может подсказать, как сохранить форматы.
если у меня в шапке не только количество, то как пользоваться универсальным макросом, чтобы он мне оставил количество, сумму, цену и т.д. в шапке, а не перевел все в столбцы?
При 1 строке с подписями макрос, в отличие от макросов МСН ,работает не корректно (сдвигает ячейки).
Посмотреть можно запустив макрос в файле-примере и указав диапазон A2:G14.
Может есть смысл пересмотреть макрос в статье?
А то не солидно получается.
Пробовал коды, первый работает, а последний код МСНа при выполнении выдает ошибку "Can`t execute code in break mode" и указывает на строку
ReDim out(1 To Application.CountA(realdata), 1 To hr + hc + 1)
Меня это интересует так как имею таблицу 200 на 200 и вопрос производительность важен.
Задал вопрос на вашем форуме, с преобразованием таблиц как в вашем примере так и в обратную сторону.
буду признателен за помощь.
Обратное преобразование - это .
И еще важнее "Обновить" и "Обновить все" один раз преобразованные Пользовательские таблицы.
Т.к. п е р в о е "преобразование" огромной Пользовательской таблицы в формат Сводной занимает десятки минут, но то же самое "Обновить" - происходит за 2-3 секунды .
Судя по датам происходящего, думаю, что имею моральное право на ссылки ("Примеры использования" там еще живы):
ПРИМ. "Придираюсь". Но, только потому, что идея, изначально предложенная здесь Николаем - наизамечательнейшая. Цены нет такой идее.
т.е.
1. обновление "неправильной таблицы"
2. запуск макроса
3. очистка заранее определенного листа с данными предыдущей "правильной" таблицы
4. заполнение листа с обновленными данными в виде "правильной" таблицы.
Спасибо.
Может, я конечно что не так делаю...
Могла бы и вручную таблицы сделать, но боюсь, код VBA не заработает.
С_П_А_С_И_Б_О !_!_!
Очень выручил и избавил от доп эмоций и выражений. Оч нужный макрос.
Макрос не хочет формировать таблицу как в примере.
Размер таблицы 404 столбца на 872 строки.
как это исправить?
Вот подскажите можно ли как то что то придумать?
Дата Часы Потребление
01.01 00:00 46548
01.01 01:00 54862
........... ......................................
31.01 24:00
и так 31 день
Эту таблицу необходимо преобразовать в вид
дата/часы 00:00 01:00 .......... 24:00
01.01 46548 54862 59765
02.01
.........
31.01
Есть ли способ это сделать макросом или формулой?
Успешно использую редизайнер но есть одна провлема, исходная таблица очень громоздкая и включает много пустых и нулевых значений. Помогите мне пожалуйста сделать так, чтобы при формировании итоговой таблицы автоматически удалялись строки с нулевыми или пустыми значениями.
Спасибо
Sub Redesigner() Dim i As Long Dim hc As Integer, hr As Integer Dim ns As Worksheet Set inpdata = ThisWorkbook.Application.InputBox( _ prompt:="Выберите обрабатываемый диапазон:", Title:="Выбор диапазона", Type:=8) hr = Val(InputBox("Сколько строк с подписями сверху?")) hc = Val(InputBox("Сколько столбцов с подписями слева?")) Application.ScreenUpdating = False i = 1 Set ns = Worksheets.Add For r = (hr + 1) To inpdata.Rows.Count For c = (hc + 1) To inpdata.Columns.Count For j = 1 To hc If inpdata.Cells(r, c) <> "" Then ns.Cells(i, j) = inpdata.Cells(r, j) End If Next j For k = 1 To hr If inpdata.Cells(r, c) <> "" Then ns.Cells(i, j + k - 1) = inpdata.Cells(k, c) End If Next k If inpdata.Cells(r, c) <> "" Then ns.Cells(i, j + k - 1) = inpdata.Cells(r, c) Else i = i - 1 End If i = i + 1 Next c Next r End SubТакже присоединяюсь к вопросу Надежды Гвиниашвили.
Как в коде с массивом не выводить пустые строки?
Заранее спасибо за помощь.
Sub Redesigner() Dim i As Long Dim hc As Integer, hr As Integer Dim ns As Worksheet Set inpdata = ThisWorkbook.Application.InputBox( _ prompt:="Выберите обрабатываемый диапазон:", Title:="Выбор диапазона", Type:=8) hr = Val(InputBox("Сколько строк с подписями сверху?")) hc = Val(InputBox("Сколько столбцов с подписями слева?")) Application.ScreenUpdating = False i = 1 Set ns = Worksheets.Add For r = (hr + 1) To inpdata.Rows.Count For c = (hc + 1) To inpdata.Columns.Count For j = 1 To hc If inpdata.Cells(r, c) <> "" Then ns.Cells(i, j) = inpdata.Cells(r, j) End If Next j For k = 1 To hr If inpdata.Cells(r, c) <> "" Then ns.Cells(i, j + k - 1) = inpdata.Cells(k, c) End If Next k If inpdata.Cells(r, c) <> "" Then ns.Cells(i, j + k - 1) = inpdata.Cells(r, c) Else i = i - 1 End If i = i + 1 Next c Next r End Subдля того, чтобы на основе исходной таблицы можно было бы строить сводные таблицы, достаточно упростить ее шапку до одной строки.
Подскажите, пожалуйста, как именно надо изменить код макроса для такой цели?
Исходная
Нужно получить
Пока делаю вручную, по несколько часов.
Спасибо!!!!
Подскажите, пожалуйста, как следует дополнить макрос, чтобы он переносил с исходной таблицы заголовки столбцов справа и добавлял автоматически заголовки для столбцов на базе строк из шапки (напр. "Шап1", "Шап2" и т.д.), а последний столбец озаглавил бы "Данные"? Никак не могу самостоятельно это реализовать.
Заранее благодарю.
Ссылка на форум
Или выгружается один столбец со значениями или таблица выводится кривая( Файл с исходными данными и результатом, в т.ч. желаемым тут
Во первых спасибо за прекрасный и полезный инструмент!
Во вторых подскажите, а можно ли его дополнить так, чтобы в итоговой таблице ячейки содержали не значения, а формулы из исходной таблицы или же ссылки на исходную таблицу.
Это нужно чтобы при изменениях в начальной 2 мерной таблице изменялись данные и в плоской.
Очень жду решения, заранее большое спасибо!
ЗЫ: Имелось ввиду и шапка, и левые столбцы то же. Т.е. конечная таблица полностью ссылалась на исходную.
объекту Cells добавить свойство Formula
Ещё раз спасибо за простой и рабочий скрипт!!
Всем добра!
Подскажите, пожалуйста, возможно ли вводить не количество столбцов и строк, а номера по порядку, тк в таблице присутствуют строки, которые не должны участвовать в дальнейшей обработке, а удалить их нельзя - тк важны первоначальным пользователям.
Заранее благодарна за ответ
Пример могу прислать
Пример могу прислать
Исходный формат
Магазин 1 00-1 час 01-02 час 02-03 час:
продовольственные товары 5 6 43
непродовольственные товары 2 1 10
Магазин 2
продовольственные товары 5 6 43
непродовольственные товары 2 1 10
Необходимая форма
00-1 час 01-02 час 02-03 час:
Магазин 1 продовольственные товары 5 6 43
Магазин 1 непродовольственные товары 2 1 10
Магазин 2 продовольственные товары 5 6 43
Магазин 2 непродовольственные товары 2 1 10
уточнение. строк с видами товаров для разных магазинов разное количество, могут встречаться различные вариации
Спасибо за макрос!
Не совсем понимаю(((
Либо есть возможность дальнейшего "корректного" разделения столбца на два?
подскажите пожалуйста =) с кодами не работаю, но частенько приходится обрабатывать подобные таблицы, думала немного облегчить себе жизнь. если не сложно)
исходная таблица
Sub Redesigner()
Dim i As Long
Dim hc As Integer, hr As Integer
Dim ns As Worksheet
Set inpdata = ThisWorkbook.Application.InputBox( _
prompt:="Выберите обрабатываемый диапазон:", Title:="Выбор диапазона", Type:=8)
hr = 0
hc = 0
Application.ScreenUpdating = False
i = 1
Set ns = Worksheets.Add
For r = (hr + 1) To inpdata.Rows.Count
For c = (hc + 1) To (inpdata.Columns.Count - 1)
For j = 1 To hc
If inpdata.Cells(r, c) <> "" Then
ns.Cells(i, j) = inpdata.Cells(r, j)
End If
Next j
For k = 1 To hr
If inpdata.Cells(r, c) <> "" Then
ns.Cells(i, j + k - 1) = inpdata.Cells(k, c)
End If
Next k
If inpdata.Cells(r, c) <> "" Then
ns.Cells(i, j + k - 1) = inpdata.Cells(r, c)
Else
i = i - 1
End If
i = i + 1
Next c
Next r
End Sub
Подскажите, каким образом разложить исходный файл на уровне продуктов до 1, например, чтобы строчка с салом дублировалась 42 раза ( по количеству значений) со значением 1, шашлык дублировался 2 раза со значением 1 и тд.
Это было бы очень удобно для использования.