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