Do Until Loop

Hi,

I'm trying to write a code that will insert three columns after finding a specific text header. I'm using a Do Until Loop which works fine on one of my previous macro's but when I have changed the text name, it doesn't seem to add in the columns and rename them.

Below is the code, can anyone spot why it seems to miss half the code?

Sub DateFormat()
'
' DateFormat Macro
' Formats the date for the journal upload
'

Dim Str1 As String

Range("a1").Select

Application.ScreenUpdating = False

Do Until ActiveCell = "Document Date"


Str2 = ActiveCell.Text

If InStr(1, Str2, "Document Date") Then
ActiveCell.Offset(0, 1).EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.Offset(0, 1) = "Year"
ActiveCell.Offset(0, 1).EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.Offset(0, 1) = "Month"
ActiveCell.Offset(0, 1).EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.Offset(0, 1) = "Day"
End If

ActiveCell.Offset(0, 1).Select

Loop

Application.ScreenUpdating = True

End Sub

Thanks