Adding three rows based on date change

[Scarlacc]

Evening I have a list that I need to add three rows everything date changes in Column E. I have one that I found works to enter 1 row each value change. Here is what list rows look like.


A. B. C. D. E LOAD # CUST # CARRIER. TRLR # DATE



A Contains a 6 digit #
B 14 digit #
C Carrier Name
D usually no more then a 5 digit #
E Date it will already be sorted in order
Date format is mm/dd/yyyy

No headers added yet so starting right at top of sheet. On average contains range of 100 rows befor I sort anything. Only cells that have blank spots in the list is the trlr # in col D. Here is code im using probably a better method but kinda new to coding excel. Any help would be appreciated.
Added picture not near computer to get a good shot tho.


Sub InsertBlankRow()
Dim rowCount As Long
rowCount = 1 'set to start row

Do

check if dates are different
If (Cells(rowCount, "E") <> Cells(rowCount + 1, "E")) Then

'if they are then add a row
Rows(rowCount + 1).Select
Selection.Insert Shift:=xlDown

'and move on beyond the new blank row
rowCount = rowCount + 2

Else
'otherwise move on to next row
rowCount = rowCount + 1
End If
'if running through list until no more then
Loop Until IsEmpty(Cells(rowCount + 1, "E"))

 

[rollis13]

Could be a solution:

Option Explicit
Sub InsertBlankRows()
    Dim rowCount As Long
    rowCount = 1                                  'set to start row
    Do
        'check if dates are different
        If (Cells(rowCount, "E") <> Cells(rowCount + 1, "E")) Then
            'if they are then add 3 rows
            Rows(rowCount + 1 & ":" & rowCount + 3).Insert Shift:=xlDown '<-- changed
            'and move on beyond the new blank row
            rowCount = rowCount + 4                                      '<-- changed
        Else
            'otherwise move on to next row
            rowCount = rowCount + 1
        End If
        'if running through list until no more then
    Loop Until IsEmpty(Cells(rowCount + 1, "E"))
End Sub

 

[Scarlacc]

Could be a solution:

Option Explicit
Sub InsertBlankRows()
    Dim rowCount As Long
    rowCount = 1                                  'set to start row
    Do
        'check if dates are different
        If (Cells(rowCount, "E") <> Cells(rowCount + 1, "E")) Then
            'if they are then add 3 rows
            Rows(rowCount + 1 & ":" & rowCount + 3).Insert Shift:=xlDown '<-- changed
            'and move on beyond the new blank row
            rowCount = rowCount + 4                                      '<-- changed
        Else
            'otherwise move on to next row
            rowCount = rowCount + 1
        End If
        'if running through list until no more then
    Loop Until IsEmpty(Cells(rowCount + 1, "E"))
End Sub

I will give it a try at work tonight

 

[Scarlacc]

Worked Perfectly thanks

 

[rollis13]

For sure . Thanks for the positive feedback, glad having been of some help.