Insert Cell above based on cell value

Question

I found this script on here and modified it some to fit my needs. However, I cannot figure out how to insert one cell instead of the entire row

Sub BlankLine()
  Dim Col As Variant
  Dim Col2 As Variant
  Dim BlankRows As Long
  Dim LastRow As Long
  Dim R As Long
  Dim StartRow As Long

  Col = "A"
  Col2 = "B"
  StartRow = 2
  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) <> .Cells(R, Col2) Then
        .Cells(R, Col2).EntireRow.Insert Shift:=xlUp
      End If
    Next R
  End With Application.ScreenUpdating = True
End Sub

So, if column A does not match Column B at any given row insert a space then keep going with the compare adding one row above any false value.

Example: 1 1
         2 3
         3 4

Becomes: 1 1
         2
         3 3
           4 

Any help would be greatly appreciated!

Answer 1

You will need to change your loop from:

For R = LastRow To StartRow + 1 Step -1
    If .Cells(R, Col) <> .Cells(R, Col2) Then
       .Cells(R, Col2).EntireRow.Insert Shift:=xlUp
    End If
Next R

to

For R = StartRow To LastRow
    If .Cells(R, Col).Value <> .Cells(R, Col2).Value Then
        .Cells(R, Col2).Insert Shift:=xlDown
    End If
Next R

A word of warning - if you data looks like this:

Example: 1 3
         2 1
         3 2

it will end up looking like this:

Becomes: 1 
         2
         3 3
           1
           2

so make sure your data is in a sensible sequence before using this.

Answer 2

.Cells(R, Col2).Insert Shift:=xlDown