主页 / 问题 / 1589071
Accepted
Григорий Шурыгин
Asked:2024-08-01 02:26:20 +0000 UTC2024-08-01 02:26:20 +0000 UTC

宏应在范围内的每个单元格后面插入另外 3 个单元格并用数据填充它们

  • 772

有一段代码是我几乎不用 BASIC 编程就组装的，更不用说 VBA 了。但有任务，需要实现，而且，我也很想弄清楚。任务是这样的：代码中有一个数组，其中有三个值，这些值是宏应该按照它们在数组中出现的顺序插入到新创建的单元格中的值。也就是说，最终的视图应该是这样的：

  1. 我选择范围
  2. 我激活宏
  3. 我看到我自己的列，但在每个单元格之后，按照数组中列出的顺序添加了另外三个包含数据的单元格。我很高兴并继续深入研究 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
excel

2 个回答

  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

    此代码适用于包含一个或多个区域的范围。如果您只需要一个区域，那么通过消除循环，代码会更加简单。

    • 1
  2. Best Answer
    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
    • 0

相关问题