VBA to insert Blank Rows According to Value in Column C

[BraytonM]

Hello all,

I have this VBA that does not work correctly when the value in Column C is "2". When I cell value is not "2," the VBA functions as it should. The idea if the value in Column C is blank, the VBA will delete the row; however, when the value in Column is <>0, it will insert that many blank rows above.

For instance, the VBA should produce the result of:

Row 2: Blank
Row 3: Blank
Row 4: AAPLES ST 2
Row 5: Blank
Row 6: Blank
Row 7: BBANANA ST 2
Row 8.... Blank

If anybody could help rewrite this so that the VBA works for "2" in Column C, I would greatly appreciate it.

The VBA that I have been using is below:

Sub DeleteAndAdd()
Dim r As Long
Dim lastrow As Long
lastrow = Cells(Rows.Count, "C").End(xlUp).Row
For r = lastrow To 1 Step -1
If Cells(r, "C") = 0 Then
Rows(r).Delete
End If
Next r

lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

For i = lastrow To 2 Step by - 1

a = ActiveSheet.Cells(i, 3).Value
For j = 1 To a

ActiveSheet.Rows(i).Select
Selection.Insert Shift:=xlDown

Next

Next

ActiveSheet.Cells(1, 1).Select

End Sub

PR Import and PER VBA_.xlsm .xlsm
	A	B	C
1	Employee No	DELETE ME	ROW ABOVE #
2	AAPLES	ST	2
3	AAPLES	RH	0
4	AAPLES	DT	0
5	AAPLES	IW	0
6	BBANANA	ST	2
7	BBANANA	RH	0
8	BBANANA	DT	0
9	BBANANA	IW	0
10	0	ST	0
11	0	RH	0
12	0	DT	0
13	0	IW	0
14	0	ST	0
15	0	RH	0
16	0	DT	0
17	0	IW	0
18	0	ST	0
19	0	RH	0
20	0	DT	0
21	0	IW	0
22	0	ST	0
23	0	RH	0
24	0	DT	0
25	0	IW	0
26	0	ST	0
27	0	RH	0
28	0	DT	0
29	0	IW	0
MASTER COPY (2)

Cell Formulas
Range	Formula
A2:A29	A2	=RowTimesheet!T40
B2,B6	B2	=IF(A2<>"","ST","")
C2:C29	C2	=SUMPRODUCT((W2:AV2<>"")/COUNTIF(W2:AV2,W2:AV2&""))
B3	B3	=IF($A$3<>"","RH","")
B4	B4	=IF($A$4<>"","DT","")
B5	B5	=IF($A$5<>"","IW","")
B7	B7	=IF($A$7<>"","RH","")
B8	B8	=IF(A8<>"","DT","")
B9	B9	=IF($A$9<>"","IW","")
B10	B10	=IF($A$10<>"","ST","")
B11	B11	=IF($A$11<>"","RH","")
B12	B12	=IF($A$12<>"","DT","")
B13	B13	=IF($A$13<>"","IW","")
B14	B14	=IF($A$14<>"","ST","")
B15	B15	=IF($A$15<>"","RH","")
B16	B16	=IF(A$16<>"","DT","")
B17	B17	=IF($A$17<>"","IW","")
B18	B18	=IF($A$18<>"","ST","")
B19	B19	=IF($A$19<>"","RH","")
B20	B20	=IF($A$20<>"","DT","")
B21	B21	=IF($A$21<>"","IW","")
B22	B22	=IF($A$22<>"","ST","")
B23	B23	=IF($A$23<>"","RH","")
B24	B24	=IF($A$24<>"","DT","")
B25	B25	=IF($A$25<>"","IW","")
B26	B26	=IF($A$26<>"","ST","")
B27	B27	=IF($A$27<>"","RH","")
B28	B28	=IF($A$28<>"","DT","")
B29	B29	=IF($A$29<>"","IW","")

 

[maabadi]

Try one of these two formula for fixing:

=IF(SUMPRODUCT((W2:AV2<>"")/COUNTIF(W2:AV2,W2:AV2&""))=0,,(SUMPRODUCT((W2:AV2<>"")/COUNTIF(W2:AV2,W2:AV2&""))+0))

Or

=IF(SUMPRODUCT((W2:AV2<>"")/COUNTIF(W2:AV2,W2:AV2&""))=0,,(SUMPRODUCT((W2:AV2<>"")/COUNTIF(W2:AV2,W2:AV2&""))*1))

 

[maabadi]

Or Change Macro to This (with you fixing formula):

Sub DeleteAndAdd()
Dim r As Long, lastrow As Long
   lastrow = Cells(Rows.Count, "C").End(xlUp).Row
For r = lastrow To 1 Step -1
  If Cells(r, "C") = 0 Then Rows(r).Delete
Next r
   lastrow = Cells(Rows.Count, 1).End(xlUp).Row

For i = lastrow To 2 Step by - 1
    Rows(i).Resize(Cells(i, 3).Value-1).Insert Shift:=xlDown
Next
End Sub

 

[BraytonM]

Or Change Macro to This (with you fixing formula):

Sub DeleteAndAdd()
Dim r As Long, lastrow As Long
   lastrow = Cells(Rows.Count, "C").End(xlUp).Row
For r = lastrow To 1 Step -1
  If Cells(r, "C") = 0 Then Rows(r).Delete
Next r
   lastrow = Cells(Rows.Count, 1).End(xlUp).Row

For i = lastrow To 2 Step by - 1
    Rows(i).Resize(Cells(i, 3).Value-1).Insert Shift:=xlDown
Next
End Sub

I will try both of these early this afternoon. Again, thank you for all your time and help!

 

[BraytonM]

Or Change Macro to This (with you fixing formula):

Sub DeleteAndAdd()
Dim r As Long, lastrow As Long
   lastrow = Cells(Rows.Count, "C").End(xlUp).Row
For r = lastrow To 1 Step -1
  If Cells(r, "C") = 0 Then Rows(r).Delete
Next r
   lastrow = Cells(Rows.Count, 1).End(xlUp).Row

For i = lastrow To 2 Step by - 1
    Rows(i).Resize(Cells(i, 3).Value-1).Insert Shift:=xlDown
Next
End Sub

I have tried changing the SUMPRODUCT formula by itself and performing the VBA and it did not add the appropriate amount of row. When I tried to run VBA, I get the following error.

 

[maabadi]

Sorry my fault. Try this with your fixation formula:

Sub DeleteAndAdd()
Dim r As Long, lastrow As Long, i As Long
   lastrow = Cells(Rows.Count, "C").End(xlUp).Row
For r = lastrow To 1 Step -1
  If Cells(r, "C") = 0 Then Rows(r).Delete
Next r
   lastrow = Cells(Rows.Count, 1).End(xlUp).Row

For i = lastrow To 2 Step -1
    If Cells(i, 3).Value > 1 Then Rows(i).Resize(Cells(i, 3).Value - 1).Insert Shift:=xlDown
Next
End Sub

But also Test my formulas at Post 11 with Previous Macro I sent:

Sub DeleteAndAdd()
Dim r As Long, lastrow As Long, i As Long
   lastrow = Cells(Rows.Count, "C").End(xlUp).Row
For r = lastrow To 1 Step -1
  If Cells(r, "C") = 0 Then Rows(r).Delete
Next r
   lastrow = Cells(Rows.Count, 1).End(xlUp).Row

For i = lastrow To 2 Step -1
   Rows(i).Resize(Cells(i, 3).Value).Insert Shift:=xlDown
Next
End Sub

 

[BraytonM]

Sorry my fault. Try this with your fixation formula:

Sub DeleteAndAdd()
Dim r As Long, lastrow As Long, i As Long
   lastrow = Cells(Rows.Count, "C").End(xlUp).Row
For r = lastrow To 1 Step -1
  If Cells(r, "C") = 0 Then Rows(r).Delete
Next r
   lastrow = Cells(Rows.Count, 1).End(xlUp).Row

For i = lastrow To 2 Step -1
    If Cells(i, 3).Value > 1 Then Rows(i).Resize(Cells(i, 3).Value - 1).Insert Shift:=xlDown
Next
End Sub

But also Test my formulas at Post 11 with Previous Macro I sent:

Sub DeleteAndAdd()
Dim r As Long, lastrow As Long, i As Long
   lastrow = Cells(Rows.Count, "C").End(xlUp).Row
For r = lastrow To 1 Step -1
  If Cells(r, "C") = 0 Then Rows(r).Delete
Next r
   lastrow = Cells(Rows.Count, 1).End(xlUp).Row

For i = lastrow To 2 Step -1
   Rows(i).Resize(Cells(i, 3).Value).Insert Shift:=xlDown
Next
End Sub

Unfortunately, neither of these suggestions have worked for me. I will upload a screen recording later today of what is happening so that maybe, we can decipher where the error is coming from.