VBA to insert Blank Rows According to Value in Column C

BraytonM

New Member
Joined
Jul 25, 2021
Messages
24
Office Version
  1. 365
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
ABC
1Employee NoDELETE MEROW ABOVE #
2AAPLESST2
3AAPLESRH0
4AAPLESDT0
5AAPLESIW0
6BBANANAST2
7BBANANARH0
8BBANANADT0
9BBANANAIW0
100ST0
110RH0
120DT0
130IW0
140ST0
150RH0
160DT0
170IW0
180ST0
190RH0
200DT0
210IW0
220ST0
230RH0
240DT0
250IW0
260ST0
270RH0
280DT0
290IW0
MASTER COPY (2)
Cell Formulas
RangeFormula
A2:A29A2=RowTimesheet!T40
B2,B6B2=IF(A2<>"","ST","")
C2:C29C2=SUMPRODUCT((W2:AV2<>"")/COUNTIF(W2:AV2,W2:AV2&""))
B3B3=IF($A$3<>"","RH","")
B4B4=IF($A$4<>"","DT","")
B5B5=IF($A$5<>"","IW","")
B7B7=IF($A$7<>"","RH","")
B8B8=IF(A8<>"","DT","")
B9B9=IF($A$9<>"","IW","")
B10B10=IF($A$10<>"","ST","")
B11B11=IF($A$11<>"","RH","")
B12B12=IF($A$12<>"","DT","")
B13B13=IF($A$13<>"","IW","")
B14B14=IF($A$14<>"","ST","")
B15B15=IF($A$15<>"","RH","")
B16B16=IF(A$16<>"","DT","")
B17B17=IF($A$17<>"","IW","")
B18B18=IF($A$18<>"","ST","")
B19B19=IF($A$19<>"","RH","")
B20B20=IF($A$20<>"","DT","")
B21B21=IF($A$21<>"","IW","")
B22B22=IF($A$22<>"","ST","")
B23B23=IF($A$23<>"","RH","")
B24B24=IF($A$24<>"","DT","")
B25B25=IF($A$25<>"","IW","")
B26B26=IF($A$26<>"","ST","")
B27B27=IF($A$27<>"","RH","")
B28B28=IF($A$28<>"","DT","")
B29B29=IF($A$29<>"","IW","")
 
Try one of these two formula for fixing:
Excel Formula:
=IF(SUMPRODUCT((W2:AV2<>"")/COUNTIF(W2:AV2,W2:AV2&""))=0,,(SUMPRODUCT((W2:AV2<>"")/COUNTIF(W2:AV2,W2:AV2&""))+0))
Or
Excel Formula:
=IF(SUMPRODUCT((W2:AV2<>"")/COUNTIF(W2:AV2,W2:AV2&""))=0,,(SUMPRODUCT((W2:AV2<>"")/COUNTIF(W2:AV2,W2:AV2&""))*1))
 
Upvote 0

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
Or Change Macro to This (with you fixing formula):
VBA Code:
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
 
Upvote 0
Or Change Macro to This (with you fixing formula):
VBA Code:
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!
 
Upvote 0
Or Change Macro to This (with you fixing formula):
VBA Code:
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
1630424699628.png

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.
 
Upvote 0
Sorry my fault. Try this with your fixation formula:
VBA Code:
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:
VBA Code:
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
 
Upvote 0
Sorry my fault. Try this with your fixation formula:
VBA Code:
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:
VBA Code:
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.
 
Upvote 0

Forum statistics

Threads
1,213,567
Messages
6,114,342
Members
448,570
Latest member
rik81h

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top