Страницы: 1
RSS
Добавить ячейки в таблицу
 
Всем доброго дня!

Есть таблица состоящая и огромного множества строк заполненных информацией, и вот так вышло, что к каждой нужно добавить дополнительные сведения и все в отдельные ячейки. Вот так: https://wampi.ru/image/lhrjy
Уверен что есть какой-то типовой прием на это случай, но никак не могу его найти. Буду очень признателен за помощь.
 
Должно быть... Но нету. :(
Проделываете одну итерацию вручную, записывая это дело рекордером. К полученному коду пристраиваете цикл.
Удобнее результат выводить на другой лист.
 
А как узнать количество ячеек, которые необходимо добавить? В вашем примере к первой ячейке добавили 5 ячеек, а во второй 4...
 
Ник Никитич,число строк всегда будет одно и тоже. Пример условный.
 
Hugo, Из предложенного вами решения я могу только "проделать одну итерацию вручную")) Остальное поясните, пожалуйста, подробнее.
 
Я думаю, что Hugo имел ввиду, что Вы запускаете макрорекодер, и добавляете ячейки вручную. Получаете макрос, делаете цикл на все ячейки, и получаете готовый макрос. Или прикрепите пример.
 
Ник Никитич, макро-рекордер запустил, макрос создал (лог ниже), но работает он не так как я ожидал и с циклом беда.
Прикрепляю пример.
Код
Sub Ячейки()
    Rows("12:12").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("B11:B15").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
End Sub
Изменено: Kacktuz - 28.08.2017 13:18:29
 
Пробуйте
Код
Sub kaktuz()
Dim iclr As Long
Dim i As Long
iclr = Cells(Rows.Count, 2).End(xlUp).Row
    For i = iclr To 2 Step -1
        Rows(i).Select
        ActiveCell.Resize(4).EntireRow.Insert
        Range(Cells(i, 2), Cells(i + 4, 2)).Merge
        Cells(i, 3).Resize(5, 1).Value = Application.Transpose(Array("элемент-1", "элемент-2", "элемент-3", "элемент-4", "элемент-5"))
    Next i
End Sub
 
Ник Никитич, обалдеть, все работает!!! При много благодарен!
Где можно научиться такому?
Страницы: 1
Наверх