Приветствую! Изначально погнался за красотой таблицы теперь кусаю локти Есть многоуровневая таблица ( в примере только два города в рабочей таблице их более 100). Хочу ее перевести в классическую таблицу. Наткнулся на пример от Николая. Но он не совсем справляется. Для его работы разбиваю таблицу на области и каждую область прохожу макросом отдельно , тем самым создавая кучу новых листов. Можно ли как то доработать макрос чтобы он справился с моими заграмождениями( обработать все области сразу) ? Заранее спасибо!
Макрос из примера:
Код
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
можно так наверное. с Вашим результатом сверил по одной области, всё сошлось. А там мало ль чего упустил..
Код
Sub fltbl()
Dim mass()
lr = ActiveSheet.UsedRange.Rows.Count
lc = ActiveSheet.UsedRange.Columns.Count
ReDim mass(1 To (lr - 11) * (lc - 7), 1 To 7)
n = 11
For i = 12 To lr
If Cells(i, 5).Value = "" Then
n = i
Else
For j = 8 To lc Step 2
If Cells(n, j).Value <> "" Then
a = a + 1
mass(a, 1) = Cells(i, 3).Value: mass(a, 2) = Cells(i, 4).Value
mass(a, 3) = Cells(i, 5).Value: mass(a, 4) = Cells(i, 6).Value
mass(a, 5) = Cells(i, 7).Value: mass(a, 6) = Cells(n, j).Value
mass(a, 7) = Cells(i, j).Value
End If
Next
End If
Next
Worksheets.Add
Range("A2").Resize(a, 7).Value = mass()
End Sub
yozhik, Не совсем то , в примере , ваш результат.Там нету названий марок у одной области( у первой). Необходимо чтобы через макрос я смог обработать несколько областей сразу , а точнее все сразу.
yozhik,Применяю Ваш пример на основную таблицу, выдает ошибку.Макрос надо изменить ? ( Извините не силен в них ) Скопировал весь лист с основной таблицей в книгу ( в свой пример , где уже Ваш макрос ).
по фотографии сложно лечить) такая ошибка возникает при попытке присвоения переменной, объявленной с одним типом данных, данных другого типа. В коде нигде ничего не объявляется, кроме массива
меня по ссылкам не пускает. Можно не весь файл, первые 30-50 строчек листа, с таблицей, которую преобразовать надо. Именно с 1-ой строки по 30-50-ю, как есть
от был бы сразу такой пример, без отступов в два столбца слева и 11 строк сверху...)
Код
Sub fltbl()
Dim mass()
lr = ActiveSheet.UsedRange.Rows.Count
lc = ActiveSheet.UsedRange.Columns.Count
ReDim mass(1 To (lr - 3) * (lc - 5), 1 To 7) ' lr-3 - минус 3 первые строки шапки, lc-5 - марки с 6-го столбца, поэтому -5
n = 3 'номер первой строки с названиями марок
For i = 4 To lr ' с четвертой строки начинаем сбор данных
If Cells(i, 3).Value = "" Then
n = i 'следующая строка с марками, когда в третьем столбце пусто
Else
For j = 6 To lc Step 2 ' марки с 6-го столбца
If Cells(n, j).Value <> "" Then
a = a + 1
mass(a, 1) = Cells(i, 1).Value: mass(a, 2) = Cells(i, 2).Value
mass(a, 3) = Cells(i, 3).Value: mass(a, 4) = Cells(i, 4).Value
mass(a, 5) = Cells(i, 5).Value: mass(a, 6) = Cells(n, j).Value
mass(a, 7) = Cells(i, j).Value
End If
Next
End If
Next
Worksheets.Add
Range("A2").Resize(a, 7).Value = mass()
End Sub
Все сработало! Спасибо! Но сразу увидел что перенеслись значения, а не функции(они должны остаться ,значения меняются постоянно) которые были в исходной таблице(Лист2) Не думал что встанет и такой вопрос
yozhik,Перенеслась одна строчка и выдало ошибку. Что сделал не так? Необходим весь файл?
Код
Код такой:
Sub fltbl()
Dim mass()
lr = ActiveSheet.UsedRange.Rows.Count
lc = ActiveSheet.UsedRange.Columns.Count
ReDim mass(1 To (lr - 3) * (lc - 5), 1 To 7) ' lr-3 - минус 3 первые строки шапки, lc-5 - марки с 6-го столбца, поэтому -5
n = 3 'номер первой строки с названиями марок
For i = 4 To lr ' с четвертой строки начинаем сбор данных
If Cells(i, 3).Value = "" Then
n = i 'следующая строка с марками, когда в третьем столбце пусто
Else
For j = 6 To lc Step 2 ' марки с 6-го столбца
If Cells(n, j).Value <> "" Then
a = a + 1
mass(a, 1) = Cells(i, 1).Value: mass(a, 2) = Cells(i, 2).Value
mass(a, 3) = Cells(i, 3).Value: mass(a, 4) = Cells(i, 4).Value
mass(a, 5) = Cells(i, 5).FormulaLocal: mass(a, 6) = Cells(n, j).Value
mass(a, 7) = Cells(i, j).FormulaLocal
End If
Next
End If
Next
Worksheets.Add
Range("A2").Resize(a, 7).Value = mass()
End Sub
давайте лучше файл на почту, в личке почту написал, быстрее будет разобраться. У меня формулы на примере переносятся, правда те которые в брендах без значений, т.к. там ссылки на Ваши другие книги
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
yozhik, ну тогда чисто в копилку - штука очень шустрая и крутая. МАСТХЭВ
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
И все же , ошибку сам не устранил. Перехожу на Лист2 нажимаю Alt+F8 , выбираю нужный макрос(fltbl) , создает новый лист с одной строчкой информации и выдает туже ошибку. Помогите пожалуйста , где я мог допустить ошибку , у yozhik, работает у меня нет(