根据填充的单元格数（每列中）插入空白行

我有一个小样本的示例数据表，如果我能使这个过程正常工作，将会填充更多的数据。

我想要做的是，根据填充在每行中的单元格数量，在同一行下面插入相同数量的空行，并将所有空白的列全部复制下来。 我附加了两个截图 – 开始和结束的样子之前和之后，以及用于实现空行插入的代码。 到目前为止，它所做的只是一致地添加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

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

 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块内的CountA工作表函数来确定填充单元的数量。 那么只需要用每一行的数量代替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