Inserting blank rows depending on number of cells (in each column) filled - vba

Question

I have a small sample example sheet of data, which will be filled with much more data if I can get this process to work.
What I am trying to do is, based upon the number of cells that are filled in each row, insert the same number of blank lines under that same row and copy everything down all columns that are blank. I have attached two screenshots - a before and after of what the start and end look like, as well as the code used for implementing the blank row insert. So far, all it does is add 8 rows consistently, and is using an older version of Excel. I'm trying to translate it into the new VBA format, but I can't seem to get it to work.
Start:
The result I'm trying to achieve:
Code:
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
I also have another bit of code that I've been trying to use to get this to function properly.
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

I find that storing the values in variant arrays can help.
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

You can use a the CountA Worksheet Function inside your IF block to determine the count of filled cells. Then just replace the 8's with the count of each row.
See code:
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