макрос должен вставлять после каждой ячейки в диапазоне дополнительно 3 ячейки и заполнять их данными

Question

есть код который я собрал практически не программируя на бэйсике и тем более VBA. Но задача есть и реализовать её надо, к тому же мне очень хочется разобраться в этом. Задача такая, в коде есть массив в котором три значения, это те значения которые макрос должен в том же порядке в каком они стоят в массиве, вставлять в новосозданные ячейки. То есть вид в итоге должен быть такой:

Я выбираю диапазон
Активирую макрос
Вижу свой же столбец но после каждой ячейки добавлено ещё три ячейки с данными в том порядке в котором они указаны в массиве. Я радуюсь и продолжаю погружаться в VBA.

код:

Sub InsertRowsAtIntervalsWithValues()
'Updateby Extendoffice
Dim Rng As Range
Dim xInterval As Integer
Dim xRows As Integer
Dim xRowsCount As Integer
Dim xNum1 As Integer
Dim xNum2 As Integer
Dim WorkRng As Range
Dim xWs As Worksheet
Dim i As Integer
Dim j As Integer
Dim x As Integer
Dim dataArray() As Variant

xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
xRowsCount = WorkRng.Rows.Count
xInterval = Application.InputBox("Enter row interval. ", xTitleId, 3, Type:=1)
xRows = 3
x = 2
j = 0

' Вставляем текстовые значения в массив dataArray
ReDim dataArray(xRows - 1) ' Размер массива равен количеству строк
dataArray(0) = "Зачет аванса"
dataArray(1) = "Гарантийное удержание"
dataArray(2) = "Итого к оплате"

' ... (остальной код макроса)

xNum1 = WorkRng.Row
xNum2 = xRows + xInterval
Set xWs = WorkRng.Parent

' Вставляем строки и заполняем их данными
For i = 1 To xRowsCount ' Изменили условие цикла
    xWs.Range(xWs.Cells(xNum1, WorkRng.Column), xWs.Cells(xNum1 + xRows - 1, WorkRng.Column)).Select
    Application.Selection.EntireRow.Insert
    
    ' Заполняем строки данными из dataArray
    If j <= x Then ' Итерируем по элементам массива
        xWs.Cells(xNum1 + j, WorkRng.Column).Value = dataArray(j)
        j = j + 1
    Else
        j = 0
    End If
    
    xNum1 = xNum1 + xNum2
Next
End Sub

Answer 1

Если сделать как в описании (1-2-3), то можно так:

Sub Fill3()
    Data = Array("Зачет аванса", "Гарантийное удержание", "Итого к оплате")
    Size = UBound(Data) - LBound(Data) + 1
    Set Rng = Intersect(Selection, ActiveSheet.Columns(Selection.Column))
    Rng.Offset(, 1).EntireColumn.Resize(, Size).Insert
    For Each cl In Rng
        cl.Offset(, 1).Resize(, Size) = Data
    Next
End Sub

Этот код работает с диапазонами, содержащими одну или несколько областей. Если нужно только с одной областью, то код будет еще проще за счет исключения цикла.

Answer 2

Option Explicit

Sub InsertRowsAtIntervalsWithValues()
  Dim xRows As Integer, WorkRng As Range
  Dim x As Integer, yf As Long, yl As Long, i As Long
  
  Set WorkRng = Application.Selection
  x = WorkRng.Column
  yf = WorkRng.Row + 1
  yl = yf + WorkRng.Rows.Count - 1
  
  Dim dataArray As Variant
  ' нужен вертикальный массив
  dataArray = WorksheetFunction.Transpose( _
    Array("Зачет аванса", "Гарантийное удержание", "Итого к оплате"))
  xRows = UBound(dataArray, 1) - LBound(dataArray, 1) + 1

  For i = yl To yf Step -1 ' нужно идти в обратном порядке, поскольку диапазон
    ' расширяется вниз в процессе работы
    Cells(i, x).Resize(xRows, 1).EntireRow.Insert
    Cells(i, x).Resize(xRows, 1) = dataArray
  Next
End Sub

БЛОГ НА HUSL

макрос должен вставлять после каждой ячейки в диапазоне дополнительно 3 ячейки и заполнять их данными

Ответы (2 шт):