Insert Cell after unequal value, copy, then delete inserted rows - loops

Question

Hi there I have created the following two macros however it is inserting a row after the last cell with data. I believe this is a result of my loop condition being Do Until ActiveCell.Value = "". I would like to have the loop stop at the last cell with data.
I tried using variables Do Until Loop_Long = LastRow but this did not work for me.
All I would like is to have a macro insert a row between cells with unlike data. Then a macro that will find empty cells in the column,the ones we previously inserted, and then delete the row.
As outlined above the issue is it is inserting an extra row and not deleting it, if you put values all the way down column B after your data in column A you will see what I mean.
Here is my code:
Option Explicit
Sub Macro1()
'Insert Blank Row Between Names
Sheets("Sheet1").Select
Range("A1").Select
Do Until ActiveCell.Value = ""
If ActiveCell.Value <> ActiveCell.Offset(1).Value Then
ActiveCell.Offset(1).EntireRow.Insert
ActiveCell.Offset(1).Select
End If
ActiveCell.Offset(1).Select
Loop
End Sub
Sub Macro2()
Dim LastRow As Long
'Delete Inserted Rows
Sheets("Sheet1").Select
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("A" & LastRow).Select
Do Until ActiveCell.Value = Range("A1")
If ActiveCell.Value <> ActiveCell.Offset(-1).Value Then
ActiveCell.Offset(-1).EntireRow.Delete Shift:=xlUp
ActiveCell.Offset(-1).Select
End If
ActiveCell.Offset(-1).Select
Loop
End Sub

Answer 1

From what you've told me, the below code should work for you (and it better follows best practices)... Have you considered copying the data as is and then inserting the rows once you've pasted the data to the new location? That would cut out a step.
Option Explicit
'Declare module-level variables.
Dim sht As Worksheet
Dim Cell As Range
Dim NameRng As Range
Dim LastRow As Long
Sub test()
'Add blank rows.
Set sht = ActiveWorkbook.Sheets("Sheet1")
LastRow = sht.Range("A" & Rows.count).End(xlUp).Row
Set NameRng = sht.Range("A1:A" & LastRow)
For Each Cell In NameRng
If Cell <> Cell.Offset(1, 0) And Cell <> "" Then
Cell.Offset(1, 0).EntireRow.Insert
End If
Next Cell
End Sub
Sub test2()
'Delete blank rows.
Set sht = ActiveWorkbook.Sheets("Sheet1")
LastRow = sht.Range("A" & Rows.count).End(xlUp).Row
Set NameRng = sht.Range("A1:A" & LastRow + 1)
For Each Cell In NameRng
If Cell = "" Then
Cell.EntireRow.Delete
End If
Next Cell
End Sub