How to compare columns and leave a blank when there is a difference


My code works for maximum of 1000 rows but my database consist of 57,000 rows. As a result it doesnt run and gets hang. Could you please help me?

Sub insertRows()



Dim lrow As Long: lrow = Range(“A” & Rows.Count).End(xlUp).Row

Dim brng As Range: Set brng = Range(“A1:H” & lrow)

brng.Copy Range(“I1”): Range(“I1”).Value = “After”

Dim arng As Range: Set arng = Range(“I3:I” & lrow)

Dim rng As Range


For Each rng In arng

  If rng <> rng.Offset(, 2) Then

      If rng > rng.Offset(, 2) Then

        rng.Resize(, 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove


        rng.Offset(, 2).Resize(, 6).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

      End If

  End If

Next rng


End Sub

By: Farhana

Leave a Reply

Your email address will not be published. Required fields are marked *