Добрый вечер, знатоки Excel. Нужна Ваша помощь, есть таблица данных намного больше чем в прилагаемом примере и постоянно меняется. На этом же сайте помогли сделать макрос для копирования данных таблицы в новый лист в один столбец. Но теперь необходимо подкорректировать, то есть данные первого столбца должны копироваться под подрядят в новом столбце левее и в последующих заголовках названия тоже должны копироваться в низ по количеству своих данных. Заранее спасибо!
Добрый вечер, знатоки Excel. Нужна Ваша помощь, есть таблица данных намного больше чем в прилагаемом примере и постоянно меняется. На этом же сайте помогли сделать макрос для копирования данных таблицы в новый лист в один столбец. Но теперь необходимо подкорректировать, то есть данные первого столбца должны копироваться под подрядят в новом столбце левее и в последующих заголовках названия тоже должны копироваться в низ по количеству своих данных. Заранее спасибо!baaur
Давно пользуюсь редизайнером по ссылке которую выложила Pelena выше. Решил еще раз сегодня перейти и почитать для общего образования. Думал может что интересного новенького появилось... Потом спустился там же читать комментарии и наткнулся на модернизированный код от МСН и небольшого дополнения от одного из пользователей дружественного ресурса. В конечном итого добавил скажем так конечный штрих от себя и получил действительно улучшенное решение по сравнению с тем что предложено Николаем. В итоге редизайнер от МСН вышел таким вот: [vba]
Код
Sub RedesignerMCH() Dim inpdata As Range, realdata As Range, ns As Worksheet Dim i&, j&, k&, c&, r&, hc&, hr& Dim out(), dataArr, hcArr, hrArr On Error GoTo line1 Set inpdata = Application.InputBox(prompt:="Выберите обрабатываемый диапазон:", Title:="Выбор диапазона", Type:=8)
hr = InputBox("Сколько строк с подписями данных сверху") hc = InputBox("Сколько столбцов с подписями данных слева?") On Error GoTo 0
Application.ScreenUpdating = False 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) Set ns = Worksheets.Add
For i = 1 To UBound(dataArr, 1) For j = 1 To UBound(dataArr, 2) 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) Next j, i ns.Cells(2, 1).Resize(UBound(out, 1), UBound(out, 2)) = out Application.ScreenUpdating = True line1: End Sub
[/vba]
Касаемо того, что добавил в этот код от себя, то это сущая мелочь, а именно [vba]
Код
On Error GoTo line1 .... On Error GoTo 0 .... line1:
[/vba] Но если не добавить эти строки, то при отмене, когда выдается запрос на выбор диапазона, будет выскакивать ошибка, что не есть красиво.
В целом очень быстро и красиво!
Давно пользуюсь редизайнером по ссылке которую выложила Pelena выше. Решил еще раз сегодня перейти и почитать для общего образования. Думал может что интересного новенького появилось... Потом спустился там же читать комментарии и наткнулся на модернизированный код от МСН и небольшого дополнения от одного из пользователей дружественного ресурса. В конечном итого добавил скажем так конечный штрих от себя и получил действительно улучшенное решение по сравнению с тем что предложено Николаем. В итоге редизайнер от МСН вышел таким вот: [vba]
Код
Sub RedesignerMCH() Dim inpdata As Range, realdata As Range, ns As Worksheet Dim i&, j&, k&, c&, r&, hc&, hr& Dim out(), dataArr, hcArr, hrArr On Error GoTo line1 Set inpdata = Application.InputBox(prompt:="Выберите обрабатываемый диапазон:", Title:="Выбор диапазона", Type:=8)
hr = InputBox("Сколько строк с подписями данных сверху") hc = InputBox("Сколько столбцов с подписями данных слева?") On Error GoTo 0
Application.ScreenUpdating = False 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) Set ns = Worksheets.Add
For i = 1 To UBound(dataArr, 1) For j = 1 To UBound(dataArr, 2) 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) Next j, i ns.Cells(2, 1).Resize(UBound(out, 1), UBound(out, 2)) = out Application.ScreenUpdating = True line1: End Sub
[/vba]
Касаемо того, что добавил в этот код от себя, то это сущая мелочь, а именно [vba]
Код
On Error GoTo line1 .... On Error GoTo 0 .... line1:
[/vba] Но если не добавить эти строки, то при отмене, когда выдается запрос на выбор диапазона, будет выскакивать ошибка, что не есть красиво.