插入空白行取决于填充的单元格数量（在每列中）

Question

我有一个小样本示例数据表单，如果我可以使此过程生效，它将填充更多数据。

我想要做的是，根据每行填充的单元格数量，在同一行下面插入相同数量的空行，并将所有空白行的所有列全部复制下来。我附加了两个截图 - 开始和结束样式的前后，以及用于实现空行插入的代码。到目前为止，它所做的只是一致地添加8行，并使用旧版本的Excel。我试图将它翻译成新的VBA格式，但我似乎无法使其工作。

开始：

结果我想要实现：

代码：

Sub IfYes() 
Dim Col As Variant 
Dim Y As Variant 
Dim BlankRows As Long 
Dim LastRow As Long 
Dim R As Long 
Dim C As Long 
Dim StartRow As Long 
Col = "AS" 
Y = "Y" 
StartRow = 1 
BlankRows = 1 
LastRow = Cells(Rows.Count, Col).End(xlUp).Row 
Application.ScreenUpdating = False 
With ActiveSheet 
    For R = LastRow To StartRow + 1 Step -1 
     If .Cells(R, Col) = "Yes" Then 
      .Cells(R, Col).Offset(1, 0).Resize(8, 1).EntireRow.Insert 
      .Cells(R, StartRow).Offset(1, 0).Resize(8, 1).Value = .Cells(R, 1).Value 
      For C = 1 To 8 Step 1 
       .Cells(R, Y).Offset(C, 0).Value = .Cells(R, Col).Offset(0, C).Value 
      Next C 
      .Cells(R, Col) = "Done" 
     End If 
    Next R 
End With 
Application.ScreenUpdating = True 
    End Sub 

我也有另一个代码位，我一直在尝试使用使其正常运作。

Dim wb1 As Workbook, ws1 As Worksheet 
Dim lRow As Long 
Dim LastRow As Range 
Dim StartRow As Range 
Dim i As Long 

Set wb1 = Application.Workbooks.Open("Z:\Employee Folders\Jason\crystal spreadsheet - start.xls") 
Set ws1 = wb1.Worksheets("AMZStart") 

With ws1 
For lRow = Cells(Cells.Rows.Count, "B").End(xlUp).Row To 1 Step -1 
    If Cells(lRow, "B") = "AMZ" Then Rows(lRow).Offset(1, 0).EntireRow.Insert 
Next lRow 
LastRow = Range("C" & Rows.Count).End(xlUp).Row + 1 
StartRow = 1 
For i = StartRow To LastRow 
If Cells(i, "C") = "" And i > StartRow Then 
Cells(i, "C").Formula = "=SUM(C" & StartRow & ":C" & i - 1 & ")" 
StartRow = i + 1 
End If 
Next 
End With 
End Sub 

Answer 1

我发现将值存储在变量数组中可以提供帮助。

Sub expand_Entries() 
    Dim v As Long, vAMZs As Variant, vVALs As Variant 
    Dim rw As Long, c1 As Long, c2 As Long, c As Long, cs As Long 

    With Worksheets("Sheet2") 
     c1 = Application.Match("status", .Rows(1), 0) 
     c2 = .Cells(1, Columns.Count).End(xlToLeft).Column 
     For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 
      cs = Application.CountA(.Cells(rw, c1 + 1).Resize(1, c2 - c1)) 
      If CBool(cs) Then 
       vVALs = .Cells(rw, 1).Resize(1, c1 - 1).Value2 
       With .Cells(rw, c1).Resize(1, cs + 1) 
        vAMZs = .Cells.Value2 
        .Offset(0, 1).ClearContents 
       End With 
       For c = UBound(vAMZs, 2) To LBound(vAMZs, 2) + 1 Step -1 
        .Cells(rw + 1, 1).Resize(1, c1 - 1).EntireRow.Insert 
        .Cells(rw + 1, 1).Resize(1, c1 - 1) = vVALs 
        .Cells(rw + 1, 8) = vAMZs(1, c) 
       Next c 
      End If 
     Next rw 
    End With 
End Sub 

Answer 2

您可以使用该​​工作表函数您IF块内确定填充细胞的数量。然后，将每行的数量替换为8。

见代码：

If .Cells(R, Col) = "Yes" Then 

     'get count 
     Dim iCells As Integer 
     iCells = WorksheetFunction.CountA(.Range("A" & R & ":R" & R)) 

     .Cells(R, Col).Offset(1, 0).Resize(iCells, 1).EntireRow.Insert 
     .Cells(R, StartRow).Offset(1, 0).Resize(iCells, 1).Value = .Cells(R, 1).Value 

     For C = 1 To iCells Step 1 
      .Cells(R, Y).Offset(C, 0).Value = .Cells(R, Col).Offset(0, C).Value 
     Next C 

     .Cells(R, Col) = "Done" 

    End If