Create a vba code to insert 2 rows based on one-column condition

[csimarketing]

I posted a question in a similar thread (Other Thread), but got a message that I should post a new thread. I based my VBA code on the previous thread mentioned but changed it to only a one-column condition. Now I need it to insert 2 rows instead of just one. I feel like I am missing something really simple here, but I played around with the code a bit and cannot get it quite right... any help would be great!

Option Explicit
Sub InsertRowsWhenValueInColumnAChanges()

    Dim wsSrc As Worksheet
    Dim lngLastRow, lngRow As Long
    Dim strKey As String
  
    Application.ScreenUpdating = False
  
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") '<- Sheet name containing the data. Change to suit if necessary.
    lngLastRow = wsSrc.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  
    For lngRow = lngLastRow To 2 Step -1
        If lngRow > 2 Then
            If Len(strKey) = 0 Then
                strKey = wsSrc.Range("A" & lngRow)
            End If
            If wsSrc.Range("A" & lngRow - 1) <> strKey Then
                Rows(lngRow).Insert
                strKey = wsSrc.Range("A" & lngRow - 1)
            End If
        End If
    Next lngRow
  
    Application.ScreenUpdating = True

End Sub

 

[Trebor76]

Hi csimarketing,

Try this:

Option Explicit
Sub InsertRowsWhenValueInColumnAChanges()

    Dim wsSrc As Worksheet
    Dim lngLastRow, lngRow As Long, i As Long
    Dim strSrc As String, strKey As String
 
    'Application.ScreenUpdating = False
 
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") '<- Sheet name containing the data. Change to suit if necessary.
    strSrc = "A" '<- Column containing data. Change to suit if necessary.
    lngLastRow = wsSrc.Range(strSrc & ":" & strSrc).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 
    For lngRow = lngLastRow To 2 Step -1
        If lngRow > 2 Then
            If Len(strKey) = 0 Then
                strKey = wsSrc.Range(strSrc & lngRow)
            End If
            If wsSrc.Range(strSrc & lngRow - 1) <> strKey Then
                wsSrc.Range(strSrc & lngRow).Resize(2).EntireRow.Insert
                strKey = wsSrc.Range(strSrc & lngRow - 1)
            End If
        End If
    Next lngRow
 
    Application.ScreenUpdating = True

End Sub

Regards,

Robert