Excel通过工作表循环来创建父项的新行

Question

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

Refer to my screenshot here

正如所看到的截图，现在我的数据是类似于“前”表。我正在尝试创建一个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