Excel循环工作表以为父项创建新行

Question

我需要一些帮助来创建一个简单的VBA来为包含变量的项目列表创建父行。

我的截图

如屏幕截图所示，此时我的数据类似于“之前”表格。我正在尝试创建一个循环遍历所有行的VBA脚本，并根据该组创建新行。我想为每个组号创建一个新行，并在该新行上，从它下面的单元格中复制某些值。

谢谢！ 纳尔逊

Answer 1

试试这个：

Sub Add_Row()

Range("I3").Select 'This assumes the first row of data after column headers is row 3

While ActiveCell <> ""

If ActiveCell.Offset(0, 1).Value <> "" Then

Selection.EntireRow.Insert

ActiveCell.Offset(0, 1).Value = ActiveCell.Offset(1, 1).Value
ActiveCell.Offset(1, 1).ClearContents
ActiveCell.Offset(0, -3).Value = ActiveCell.Offset(1, -3).Value
ActiveCell.Offset(0, -4).Value = ActiveCell.Offset(1, -4).Value & "P"

ActiveCell.Offset(1, 0).Select

Else

ActiveCell.Offset(1, 0).Select

End If

Wend

Range("A1").Select

End Sub

Answer 2

您可以像这样插入空白行：

Sub Macro1()
    Dim i As Long
    i = 3    

    Do While Cells(i, 1) <> ""
      If Cells(i, 1) <> Cells(i - 1, 1) Then
        Rows(i).Insert Shift:=xlDown
        i = i + 1
      End If
      i = i + 1
    Loop
End Sub

希望现在改变细胞不应成为问题

Answer 3

以下代码可让您轻松将其更改为您当前和未来可能的需求

根据您的链接示例，我假设“描述”列在每个“组”或“SKU”行块的开头总是有一个非空单元格

Sub CreateRowForParentItem()

Dim sht As Worksheet
Dim cell As Range
Dim descriptionCol As Long, SKUCol As Long, productCol As Long

'------------------------------
' setting stuff - begin
descriptionCol = 10 '<== adapt it to your actual "Description" column number
SKUCol = 5          '<== adapt it to your actual "SKU" column number
productCol = 6      '<== adapt it to your actual "Product Title" column number

Set sht = ThisWorkbook.Sheets("SheetFruit") '<== change 'data' sheet as per your needs
' setting stuff - end
'------------------------------


'------------------------------
' core code - begin
With sht
    Set cell = .Cells(.Rows.Count, descriptionCol).End(xlUp) '<== find last non blank cell in "Description" column
    Do While cell.value <> "Description" '<== proceed only if it's not the header cell
        cell.EntireRow.Insert
        Call CopyAndClearRange(.Cells(cell.row, SKUCol))
        Call CopyAndClearRange(.Cells(cell.row, productCol))
        Call CopyAndClearRange(.Cells(cell.row, descriptionCol), True)

        Set cell = .Cells(cell.row - 1, descriptionCol).End(xlUp) '<== find next non blank cell up
    Loop
End With
' core code - end
'------------------------------

End Sub


Sub CopyAndClearRange(rng As Range, Optional okClear As Variant)

If IsMissing(okClear) Then okClear = False
With rng
    .Copy .Offset(-1)
    If okClear Then .Clear
End With

End Sub