ОБНОВЛЕНО 19.04.15 до Версии 2 (макрос не изменился но был добавлен видеобзор на данную примочку)
Добрый день, друзья и гости. Оформить данное решение навеяла очередная тема на нашем форуме о том "как преобразовать таблицу разбитую по столбцам в плоскую?".
- Данное решение построено на массивах, авторство принадлежит МСН. - Внес небольшую коррективу, а именно запрос на выделение диапазона - Максим Зеленский, с дружеского форума. - Дополнительные улучшения и полезности - SLAVICK . - Небольшие дополнения и коррективы - DJ Marker MC
В итоге получился вот такой вот макрос:
Option Explicit Sub Redesigner_V2()
' Данное решение построено на массивах, авторство принадлежит МСН (http://www.excelworld.ru). ' Внес небольшую коррективу, а именно запрос на выделение диапазона - Максим Зеленский, с дружеского форума (http://www.planetaexcel.ru). ' Дополнительные улучшения и полезности - SLAVICK (http://www.excelworld.ru) ' Небольшие дополнения и коррективы - DJ Marker MC (http://www.excelworld.ru).
Dim inpdata As Range, realdata As Range, ns As Worksheet Dim i&, ii&, c&, r&, hc&, hr&, nSt&, nT& Dim out(), dataArr(), hcArr(), hrArr(), shapka ', shapkaFirst As Boolean OnErrorGoTo line1
Set inpdata = Application.InputBox("Выберите обрабатываемый диапазон:", "Выбор диапазона", Selection.Address, Type:=8)
hr = InputBox("Сколько строк с подписями данных сверху", , 1)
hc = InputBox("Сколько столбцов с подписями данных слева?", , 1)
nSt = InputBox("Сколько столбцов с данными будет в правой части таблицы? (например: если Ваша таблица уходит вправо на 24 месяца то указав тут 12 - месяцы разобьются по столбцам, а год перенесется по строкам", , 1) ' Проверка шапки если nSt = 1 If nSt = 1And hr > 1Then If MsgBox("Выбрано только один столбец повторения, уменьшить шапку?", vbYesNo) = vbYes Then
shapka = inpdata.Cells(hr, 1).Resize(1, hc).Value 'realdata.Value Else
shapka = inpdata.Resize(hr, hc).Value 'realdata.Value EndIf Else
shapka = inpdata.Resize(hr, hc).Value 'realdata.Value EndIf
Application.ScreenUpdating = False If inpdata.Rows.Count <= hr Or inpdata.Columns.Count <= hc ThenExitSub 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
' Проверка шапки For i = 1ToUBound(hrArr) For ii = 1ToUBound(hrArr, 2)
hrArr(i, ii) = Проверка_слова(CStr(hrArr(i, ii))) Next ii, i ' Проверка справочника For i = 1ToUBound(hcArr) For ii = 1ToUBound(hcArr, 2)
hcArr(i, ii) = Проверка_слова(CStr(hcArr(i, ii))) Next ii, i '==================================== ReDim out(1To realdata.Count / nSt, 1To hr + hc + nSt) 'Начало основного цикла
hr = 0 For i = 1ToUBound(hcArr)
hc = 1 For ii = 1ToInt(UBound(dataArr, 2) / nSt)
hr = hr + 1 For r = 1ToUBound(hrArr): out(hr, r) = hrArr(r, hc): Next r For c = 1ToUBound(hcArr, 2): out(hr, c + r - 1) = hcArr(i, c): Next c For nT = 1To nSt ' Добавление данных если не ошибка IfNotIsError(dataArr(i, hc)) Then out(hr, c + r + nT - 2) = dataArr(i, hc)
hc = hc + 1 Next Next Next Set ns = Worksheets.Add ' Добавление листа
If IsArrayEmpty(shapka) = FalseThen
ns.Cells(1, r).Resize(UBound(shapka), UBound(shapka, 2)) = shapka If nSt = 1Then ns.Cells(1, r + c - 1).Resize(UBound(shapka), nSt) = "Значения"Else ns.Cells(1, r + c - 1).Resize(UBound(shapka), nSt) = hrArr ' Выгрузка шапки столбцов
r = UBound(shapka) + 1 Else
ns.Cells(1, r) = shapka ' Выгрузка шапки строк If nSt = 1Then ns.Cells(1, r + c - 1) = "Значения"Else ns.Cells(1, r + c - 1).Resize(UBound(hrArr), nSt) = hrArr ' Выгрузка шапки столбцов
r = 2 EndIf
ns.Cells(r, 1).Resize(UBound(out), UBound(out, 2)) = out ' Выгрузка данных 'Удобности:
ns.Cells(1, 1).Resize(r - 1, UBound(out, 2)).Interior.ColorIndex = 44' Закрашивание шапки
ns.Cells(r, UBound(hrArr) + c).Select: ActiveWindow.FreezePanes = True' Закрепление шапки
ns.Range(Cells(r - 1, 1), Cells(UBound(out), UBound(out, 2))).AutoFilter ' Установка Автофильтра
' Установка границ With ns.Range(Cells(1, 1), Cells(Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row, UBound(out, 2))).Borders
.LineStyle = xlContinuous
.Weight = xlThin EndWith
Application.ScreenUpdating = True
line1: EndSub
Function IsArrayEmpty(anArray AsVariant) AsBoolean OnErrorGoTo IS_EMPTY If (UBound(anArray) >= 0) ThenExitFunction
IS_EMPTY:
IsArrayEmpty = True EndFunction
Итак по шагам.
1. К примеру имеем таблицу такого вида:
После запуска Редизайнера видим диалоговое окно в котором Вам предложено указать диапазон таблицы которую необходимо преобразовать.
2. Указываем диапазон таблицы: (если таблица была выделена до запуска макроса, то выделенный диапазон будет подхвачен автоматически)
3. Третий шаг, в диалоговом окне необходимо указать сколько строк находится в шапке таблицы. В нашем примере - три строки.
4. Следующим шагом указываем количество столбцов с данными в левой части таблицы. В нашем примере их пять - Код, Цена, Направление, Страна, Мин.уп!
5. Если мы ходим получить ПЛОСКУЮ ТАБЛИЦУ, то оставляем тут значение по умолчанию 1, если Вам будет необходимо чтоб вправо таблица была разбита помесячно, а года были разбиты вниз то поставьте 12 (вообще на этом шаге поэкспериментируйте и сами поймете как это работает. Я же оставлю тут 1, так как желаю получить плоскую таблицу
6. Последний шаг - вопрос: Хотите Вы уменьшить шапку таблицы или нет? Данный вопрос задается только в том случае, если в предыдущем шаге Вы указали - 1 или же если в шапку таблицы попадает всего одна строка (тоже попробуйте как это работает в двух вариантах методом "ТЫКА")
После того как мы нажмем "ОК", наша таблица уходящая вправо, превратится в плоскую, такого вида как на картинке ниже в левой части. Как Вы можете заметить все столбцы уже подписаны кроме первых трех (это была наша шапка), поскольку программе нету откуда взять название этих столбцов, мы подписываем их вручную. Подписываем наши столбцы и получаем готовую плоскую таблицу как в правой части картинки.
Попробовать как это работает можно с помощью приложенного файла. В целом все очень быстро и красиво! Всем приятного пользования!
ОБНОВЛЕНО 19.04.15 до Версии 2 (макрос не изменился но был добавлен видеобзор на данную примочку)
Добрый день, друзья и гости. Оформить данное решение навеяла очередная тема на нашем форуме о том "как преобразовать таблицу разбитую по столбцам в плоскую?".
- Данное решение построено на массивах, авторство принадлежит МСН. - Внес небольшую коррективу, а именно запрос на выделение диапазона - Максим Зеленский, с дружеского форума. - Дополнительные улучшения и полезности - SLAVICK . - Небольшие дополнения и коррективы - DJ Marker MC
В итоге получился вот такой вот макрос:
Option Explicit Sub Redesigner_V2()
' Данное решение построено на массивах, авторство принадлежит МСН (http://www.excelworld.ru). ' Внес небольшую коррективу, а именно запрос на выделение диапазона - Максим Зеленский, с дружеского форума (http://www.planetaexcel.ru). ' Дополнительные улучшения и полезности - SLAVICK (http://www.excelworld.ru) ' Небольшие дополнения и коррективы - DJ Marker MC (http://www.excelworld.ru).
Dim inpdata As Range, realdata As Range, ns As Worksheet Dim i&, ii&, c&, r&, hc&, hr&, nSt&, nT& Dim out(), dataArr(), hcArr(), hrArr(), shapka ', shapkaFirst As Boolean OnErrorGoTo line1
Set inpdata = Application.InputBox("Выберите обрабатываемый диапазон:", "Выбор диапазона", Selection.Address, Type:=8)
hr = InputBox("Сколько строк с подписями данных сверху", , 1)
hc = InputBox("Сколько столбцов с подписями данных слева?", , 1)
nSt = InputBox("Сколько столбцов с данными будет в правой части таблицы? (например: если Ваша таблица уходит вправо на 24 месяца то указав тут 12 - месяцы разобьются по столбцам, а год перенесется по строкам", , 1) ' Проверка шапки если nSt = 1 If nSt = 1And hr > 1Then If MsgBox("Выбрано только один столбец повторения, уменьшить шапку?", vbYesNo) = vbYes Then
shapka = inpdata.Cells(hr, 1).Resize(1, hc).Value 'realdata.Value Else
shapka = inpdata.Resize(hr, hc).Value 'realdata.Value EndIf Else
shapka = inpdata.Resize(hr, hc).Value 'realdata.Value EndIf
Application.ScreenUpdating = False If inpdata.Rows.Count <= hr Or inpdata.Columns.Count <= hc ThenExitSub 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
' Проверка шапки For i = 1ToUBound(hrArr) For ii = 1ToUBound(hrArr, 2)
hrArr(i, ii) = Проверка_слова(CStr(hrArr(i, ii))) Next ii, i ' Проверка справочника For i = 1ToUBound(hcArr) For ii = 1ToUBound(hcArr, 2)
hcArr(i, ii) = Проверка_слова(CStr(hcArr(i, ii))) Next ii, i '==================================== ReDim out(1To realdata.Count / nSt, 1To hr + hc + nSt) 'Начало основного цикла
hr = 0 For i = 1ToUBound(hcArr)
hc = 1 For ii = 1ToInt(UBound(dataArr, 2) / nSt)
hr = hr + 1 For r = 1ToUBound(hrArr): out(hr, r) = hrArr(r, hc): Next r For c = 1ToUBound(hcArr, 2): out(hr, c + r - 1) = hcArr(i, c): Next c For nT = 1To nSt ' Добавление данных если не ошибка IfNotIsError(dataArr(i, hc)) Then out(hr, c + r + nT - 2) = dataArr(i, hc)
hc = hc + 1 Next Next Next Set ns = Worksheets.Add ' Добавление листа
If IsArrayEmpty(shapka) = FalseThen
ns.Cells(1, r).Resize(UBound(shapka), UBound(shapka, 2)) = shapka If nSt = 1Then ns.Cells(1, r + c - 1).Resize(UBound(shapka), nSt) = "Значения"Else ns.Cells(1, r + c - 1).Resize(UBound(shapka), nSt) = hrArr ' Выгрузка шапки столбцов
r = UBound(shapka) + 1 Else
ns.Cells(1, r) = shapka ' Выгрузка шапки строк If nSt = 1Then ns.Cells(1, r + c - 1) = "Значения"Else ns.Cells(1, r + c - 1).Resize(UBound(hrArr), nSt) = hrArr ' Выгрузка шапки столбцов
r = 2 EndIf
ns.Cells(r, 1).Resize(UBound(out), UBound(out, 2)) = out ' Выгрузка данных 'Удобности:
ns.Cells(1, 1).Resize(r - 1, UBound(out, 2)).Interior.ColorIndex = 44' Закрашивание шапки
ns.Cells(r, UBound(hrArr) + c).Select: ActiveWindow.FreezePanes = True' Закрепление шапки
ns.Range(Cells(r - 1, 1), Cells(UBound(out), UBound(out, 2))).AutoFilter ' Установка Автофильтра
' Установка границ With ns.Range(Cells(1, 1), Cells(Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row, UBound(out, 2))).Borders
.LineStyle = xlContinuous
.Weight = xlThin EndWith
Application.ScreenUpdating = True
line1: EndSub
Function IsArrayEmpty(anArray AsVariant) AsBoolean OnErrorGoTo IS_EMPTY If (UBound(anArray) >= 0) ThenExitFunction
IS_EMPTY:
IsArrayEmpty = True EndFunction
Итак по шагам.
1. К примеру имеем таблицу такого вида:
После запуска Редизайнера видим диалоговое окно в котором Вам предложено указать диапазон таблицы которую необходимо преобразовать.
2. Указываем диапазон таблицы: (если таблица была выделена до запуска макроса, то выделенный диапазон будет подхвачен автоматически)
3. Третий шаг, в диалоговом окне необходимо указать сколько строк находится в шапке таблицы. В нашем примере - три строки.
4. Следующим шагом указываем количество столбцов с данными в левой части таблицы. В нашем примере их пять - Код, Цена, Направление, Страна, Мин.уп!
5. Если мы ходим получить ПЛОСКУЮ ТАБЛИЦУ, то оставляем тут значение по умолчанию 1, если Вам будет необходимо чтоб вправо таблица была разбита помесячно, а года были разбиты вниз то поставьте 12 (вообще на этом шаге поэкспериментируйте и сами поймете как это работает. Я же оставлю тут 1, так как желаю получить плоскую таблицу
6. Последний шаг - вопрос: Хотите Вы уменьшить шапку таблицы или нет? Данный вопрос задается только в том случае, если в предыдущем шаге Вы указали - 1 или же если в шапку таблицы попадает всего одна строка (тоже попробуйте как это работает в двух вариантах методом "ТЫКА")
После того как мы нажмем "ОК", наша таблица уходящая вправо, превратится в плоскую, такого вида как на картинке ниже в левой части. Как Вы можете заметить все столбцы уже подписаны кроме первых трех (это была наша шапка), поскольку программе нету откуда взять название этих столбцов, мы подписываем их вручную. Подписываем наши столбцы и получаем готовую плоскую таблицу как в правой части картинки.
Попробовать как это работает можно с помощью приложенного файла. В целом все очень быстро и красиво! Всем приятного пользования!DJ_Marker_MC
Хороший код - мой в разы больше Рискну дать несколько предложений по улучшению:
Во все Iputboxы проставить умолчания:
Set inpdata = Application.InputBox("Выберите обрабатываемый диапазон:", "Выбор диапазона", Selection.Address, Type:=8)
hr = InputBox("Сколько строк с подписями данных сверху", , 1)
hc = InputBox("Сколько столбцов с подписями данных слева?", , 1)
Добавить возможность за раз брать не один столбец а с выбором -например мне часто нужно брать по 12(Янв-Дек), иногда по два(шт, $)
Добавить в код проверку типа значений: У меня были проблемы с упаковками в формате "1/10" - они при выгрузке на лист преобразовывались в дату и с кодами типа "0006" = "6" . Для таких данных я сцеплял с "'" & hcArr(i, c)
Прошу камнями не забрасывать. Мне такие мелочи существенно ускорили работу, может еще кому будет полезно.
Хороший код - мой в разы больше Рискну дать несколько предложений по улучшению:
Во все Iputboxы проставить умолчания:
Set inpdata = Application.InputBox("Выберите обрабатываемый диапазон:", "Выбор диапазона", Selection.Address, Type:=8)
hr = InputBox("Сколько строк с подписями данных сверху", , 1)
hc = InputBox("Сколько столбцов с подписями данных слева?", , 1)
Добавить возможность за раз брать не один столбец а с выбором -например мне часто нужно брать по 12(Янв-Дек), иногда по два(шт, $)
Добавить в код проверку типа значений: У меня были проблемы с упаковками в формате "1/10" - они при выгрузке на лист преобразовывались в дату и с кодами типа "0006" = "6" . Для таких данных я сцеплял с "'" & hcArr(i, c)
Прошу камнями не забрасывать. Мне такие мелочи существенно ускорили работу, может еще кому будет полезно. SLAVICK
Иногда все проще чем кажется с первого взгляда.
Сообщение отредактировал SLAVICK - Среда, 04.02.2015, 20:51
Добавил лист с тем как иногда мне нужно получать данные - так удобней работать в сводной.Это моё субъективное мнение - может я в этом не одинок
Вложил простенькую функцию проверки данных - сам ею пользуюсь. Ее можно применить для справочника(т.е. для диапазона который нужно повторять), для данных наверное нет смысла... поскольку там как правило цифры.
Надеюсь мои маленькие "улучшалки" пригодятся
Добавил лист с тем как иногда мне нужно получать данные - так удобней работать в сводной.Это моё субъективное мнение - может я в этом не одинок
Вложил простенькую функцию проверки данных - сам ею пользуюсь. Ее можно применить для справочника(т.е. для диапазона который нужно повторять), для данных наверное нет смысла... поскольку там как правило цифры.
SLAVICK, очень крутая штука вышла, но мне кажется подписывать шапку не совсем правильно когда в последнем inputbox указываем "1" и соответственно количество строк сверху тоже не должно быть 3, достаточно одной строки. Предлагаю подправить немного Ваши вкусняшки и чуток допилить проверкой:
If nSt = 1Then
r = 2
ns.Cells(r, 1).Resize(UBound(out), UBound(out, 2)) = out ' Выгрузка данных
ns.Cells(1, 1).Resize(1, UBound(out, 2)).Interior.ColorIndex = 44' Закрашивание шапки
ns.Cells(1, r + c - 1).Select: ActiveWindow.FreezePanes = True' Закрепление шапки Else
ns.Cells(1, r + c - 1).Resize(UBound(hrArr), nSt) = hrArr ' Выгрузка шапки
ns.Cells(r, 1).Resize(UBound(out), UBound(out, 2)) = out ' Выгрузка данных 'Удобности:
ns.Cells(1, 1).Resize(UBound(hrArr), UBound(out, 2)).Interior.ColorIndex = 44' Закрашивание шапки
ns.Cells(r, r + c - 1).Select: ActiveWindow.FreezePanes = True' Закрепление шапки EndIf
ns.Range(Cells(r - 1, 1), Cells(UBound(out), UBound(out, 2))).AutoFilter ' Установка Автофильтра
надеюсь Вы не против, что я немного изменил цвет шапки? я лично или таким или желтым как правило шапку делаю)))
Также предлагаю изменить вопрос в последнем inputbox, поскольку я не сразу понял о чем речь, как насчет такого?
nSt = InputBox("Сколько столбцов с данными будет в правой части таблицы? (например: если Ваша таблица уходит вправо на 24 месяца то указав тут 12 - месяцы разобьются по столбцам, а год перенесется по строкам", , 1)
И уже если допиливать внешний вид, то предлагаю в конец еще вставить такой кусочек:
' Установка границ With ns.Range(Cells(1, 1), Cells(Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row, UBound(out, 2)))
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
.Borders(xlEdgeLeft).Weight = xlThin
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeRight).Weight = xlThin EndWith
Таким образом получаем красивое универсальное решение.
Что скажете?
SLAVICK, очень крутая штука вышла, но мне кажется подписывать шапку не совсем правильно когда в последнем inputbox указываем "1" и соответственно количество строк сверху тоже не должно быть 3, достаточно одной строки. Предлагаю подправить немного Ваши вкусняшки и чуток допилить проверкой:
If nSt = 1Then
r = 2
ns.Cells(r, 1).Resize(UBound(out), UBound(out, 2)) = out ' Выгрузка данных
ns.Cells(1, 1).Resize(1, UBound(out, 2)).Interior.ColorIndex = 44' Закрашивание шапки
ns.Cells(1, r + c - 1).Select: ActiveWindow.FreezePanes = True' Закрепление шапки Else
ns.Cells(1, r + c - 1).Resize(UBound(hrArr), nSt) = hrArr ' Выгрузка шапки
ns.Cells(r, 1).Resize(UBound(out), UBound(out, 2)) = out ' Выгрузка данных 'Удобности:
ns.Cells(1, 1).Resize(UBound(hrArr), UBound(out, 2)).Interior.ColorIndex = 44' Закрашивание шапки
ns.Cells(r, r + c - 1).Select: ActiveWindow.FreezePanes = True' Закрепление шапки EndIf
ns.Range(Cells(r - 1, 1), Cells(UBound(out), UBound(out, 2))).AutoFilter ' Установка Автофильтра
надеюсь Вы не против, что я немного изменил цвет шапки? я лично или таким или желтым как правило шапку делаю)))
Также предлагаю изменить вопрос в последнем inputbox, поскольку я не сразу понял о чем речь, как насчет такого?
nSt = InputBox("Сколько столбцов с данными будет в правой части таблицы? (например: если Ваша таблица уходит вправо на 24 месяца то указав тут 12 - месяцы разобьются по столбцам, а год перенесется по строкам", , 1)
И уже если допиливать внешний вид, то предлагаю в конец еще вставить такой кусочек:
' Установка границ With ns.Range(Cells(1, 1), Cells(Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row, UBound(out, 2)))
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
.Borders(xlEdgeLeft).Weight = xlThin
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeRight).Weight = xlThin EndWith
Таким образом получаем красивое универсальное решение.
На счет не подписывать шапку: Возможно и так. но тогда:
вместо
ns.Cells(1, r + c - 1).Select: ActiveWindow.FreezePanes = True' Закрепление шапки
Нужно
ns.Cells(2, r + c - 1).Select: ActiveWindow.FreezePanes = True' Закрепление шапки
А то шапка не закрепляется. Лично я против этого решения, но как говорится на вкус и цвет... :). Я наоборот, еще добавил шапку над "Справочником" с родными названиями, потому что приходится потом еще и "Обзывать" все столбцы справочника заново(особенно когда их больше 10 ) .
И уже если допиливать внешний вид, то предлагаю в конец еще вставить такой кусочек:
Только за, но можно немного упростить код:
' Установка границ With ns.Range(Cells(1, 1), Cells(Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row, UBound(out, 2))).Borders
.LineStyle = xlContinuous
.Weight = xlThin EndWith
Добавил шапку и поменял местами справочник с подписями по столбцам. Мне кажется так гораздо удобнее<_<
На счет не подписывать шапку: Возможно и так. но тогда:
вместо
ns.Cells(1, r + c - 1).Select: ActiveWindow.FreezePanes = True' Закрепление шапки
Нужно
ns.Cells(2, r + c - 1).Select: ActiveWindow.FreezePanes = True' Закрепление шапки
А то шапка не закрепляется. Лично я против этого решения, но как говорится на вкус и цвет... :). Я наоборот, еще добавил шапку над "Справочником" с родными названиями, потому что приходится потом еще и "Обзывать" все столбцы справочника заново(особенно когда их больше 10 ) .
Я правильно понял что вы против того чтоб не подписывать шапку? Объясню почему считаю правильно не подписывать шапку: 1. Если мы делаем редизайн вправо на 12 месяцев с нашей таблицы-пример, то получаем такой результат (с учетом того что редизайн делаем ТОЛЬКО продажи): Все что тут выделено красным, при подобной ситуации является ненужным и скорее всего будет удалено (ИМХО я б удалил). Но в тоже время подпись помесячной разбивки - сохранилось, а вот первые два столбца подписать в ручном режиме - думаю труда не составит.
2. Если делам редизайн в плоскую таблицу, то получаем такой результат: Опять таки, если делать редизайн только данных по продажам 10-11, то столбец в котором повторяется слово ПРОДАЖИ в целом подлежит удалению. И в то же время остается для ЕКСЕЛЯ вопрос, как подписать 3 новых столбца? - ему ведь нет откуда понять что это за столбцы, соответственно их в любом случае придется подписывать руками. Другими словами, как вариант можно добавлять подпись лишь столбцам которые находятся в левой части, точнее то количество столбцов слева которое мы указываем во втором inputbox
Я правильно понял что вы против того чтоб не подписывать шапку? Объясню почему считаю правильно не подписывать шапку: 1. Если мы делаем редизайн вправо на 12 месяцев с нашей таблицы-пример, то получаем такой результат (с учетом того что редизайн делаем ТОЛЬКО продажи): Все что тут выделено красным, при подобной ситуации является ненужным и скорее всего будет удалено (ИМХО я б удалил). Но в тоже время подпись помесячной разбивки - сохранилось, а вот первые два столбца подписать в ручном режиме - думаю труда не составит.
2. Если делам редизайн в плоскую таблицу, то получаем такой результат: Опять таки, если делать редизайн только данных по продажам 10-11, то столбец в котором повторяется слово ПРОДАЖИ в целом подлежит удалению. И в то же время остается для ЕКСЕЛЯ вопрос, как подписать 3 новых столбца? - ему ведь нет откуда понять что это за столбцы, соответственно их в любом случае придется подписывать руками. Другими словами, как вариант можно добавлять подпись лишь столбцам которые находятся в левой части, точнее то количество столбцов слева которое мы указываем во втором inputboxDJ_Marker_MC
Другими словами, как вариант можно добавлять подпись лишь столбцам которые находятся в левой части, точнее то количество столбцов слева которое мы указываем во втором inputbox
Я же это и сделал в прошлом посте. Только оставил и подпись блока данных Вы же не знаете в какой именно строке у пользователя будет подписано разные данные которые нужно оставить. Это у меня в нижней строке, а может быть и по средине, и вверху Лично мне проще удалить лишние строки и столбцы, чем подписывать недостающие данные Предлагаю сделать контрольный вопрос, если выбрано для повтора 1 столбец. типа "Добавить шапку?" тогда вариант подойдет и моим и Вашим единомышленникам
Другими словами, как вариант можно добавлять подпись лишь столбцам которые находятся в левой части, точнее то количество столбцов слева которое мы указываем во втором inputbox
Я же это и сделал в прошлом посте. Только оставил и подпись блока данных Вы же не знаете в какой именно строке у пользователя будет подписано разные данные которые нужно оставить. Это у меня в нижней строке, а может быть и по средине, и вверху Лично мне проще удалить лишние строки и столбцы, чем подписывать недостающие данные Предлагаю сделать контрольный вопрос, если выбрано для повтора 1 столбец. типа "Добавить шапку?" тогда вариант подойдет и моим и Вашим единомышленникам SLAVICK
Иногда все проще чем кажется с первого взгляда.
Сообщение отредактировал SLAVICK - Пятница, 06.02.2015, 15:20
SLAVICK, я не увидел Ваш предыдущий вариант просто, на самом деле он уже приближен к иделу. На мой взгляд все хорошо, только исправить одно НО все же стоит, наверное. Предлагаю все таки делать проверку nSt и если это значение равно 1, то выводить шапку из 1 строки, подписывать все как и подписываете, а столбец со значениями, просто подписать в принудительном порядке, например "ЗНАЧЕНИЯ"
Признаю честно, у меня на такую правку много времени уйдет))) Если Вам такой вариант понравится, не подправите?
SLAVICK, я не увидел Ваш предыдущий вариант просто, на самом деле он уже приближен к иделу. На мой взгляд все хорошо, только исправить одно НО все же стоит, наверное. Предлагаю все таки делать проверку nSt и если это значение равно 1, то выводить шапку из 1 строки, подписывать все как и подписываете, а столбец со значениями, просто подписать в принудительном порядке, например "ЗНАЧЕНИЯ"
Признаю честно, у меня на такую правку много времени уйдет))) Если Вам такой вариант понравится, не подправите?DJ_Marker_MC
Аааа... блин... понял о чем Вы... если в столбцах слева подпись будет не в 3 строке, а например во второй... ну да... тогда выходит предугадать это не выйдет. Тобеж шапку нужно оставлять так как у Вас... но все же блок с данными, при nst = 1, думаю подписывать автоматом не нужно.
up: Другими словами вот так:
If nSt <> 1Then ns.Cells(1, r + c - 1).Resize(UBound(hrArr), nSt) = hrArr ' Выгрузка шапки столбцов
Аааа... блин... понял о чем Вы... если в столбцах слева подпись будет не в 3 строке, а например во второй... ну да... тогда выходит предугадать это не выйдет. Тобеж шапку нужно оставлять так как у Вас... но все же блок с данными, при nst = 1, думаю подписывать автоматом не нужно.
up: Другими словами вот так:
If nSt <> 1Then ns.Cells(1, r + c - 1).Resize(UBound(hrArr), nSt) = hrArr ' Выгрузка шапки столбцов
Ну еще немного усовершенствовал Добавил контрольный вопрос и перепроверку шапки(раньше если выбрано кол. строк и кол. повторяемого диап. вылетал в ошибку(Ubound(шапка))).
Проверяйте вроде все ОК ЗЫ А макрос тем временем рос и рос
Ну еще немного усовершенствовал Добавил контрольный вопрос и перепроверку шапки(раньше если выбрано кол. строк и кол. повторяемого диап. вылетал в ошибку(Ubound(шапка))).
Ну тогда, наверное, нужно дополнить презентацию возможностей доступным для пользователей языком . У Вас это красиво и наглядно получается Лично я забираю код себе в копилку. Мне тоже нравится, что получилось.
Ну тогда, наверное, нужно дополнить презентацию возможностей доступным для пользователей языком . У Вас это красиво и наглядно получается Лично я забираю код себе в копилку. Мне тоже нравится, что получилось. SLAVICK
Иногда все проще чем кажется с первого взгляда.
Сообщение отредактировал SLAVICK - Суббота, 07.02.2015, 10:55
В этой теме подняли вопрос по сохранению форматов и примечаний. Решил дополнить готовый редизайнер куском кода для выбора режима с сохранением форматов или нет. По умолчанию - активируется кнопка "Нет" - тогда запускается редизайнер в обычном режиме. Если нажать "Да" - то в режиме сохранения форматов и примечаний - в этом режиме работает на порядок дольше... но зато все в точности как в исходнике. В своей надстройке заменил на эту версию(мало ли может нужно будет форматы сохранить). В общем, встречайте 3-ю версию .
В этой теме подняли вопрос по сохранению форматов и примечаний. Решил дополнить готовый редизайнер куском кода для выбора режима с сохранением форматов или нет. По умолчанию - активируется кнопка "Нет" - тогда запускается редизайнер в обычном режиме. Если нажать "Да" - то в режиме сохранения форматов и примечаний - в этом режиме работает на порядок дольше... но зато все в точности как в исходнике. В своей надстройке заменил на эту версию(мало ли может нужно будет форматы сохранить). В общем, встречайте 3-ю версию .SLAVICK