Insert Row where value not found

Hi jordan2322
See if this code does as you require

Option Explicit
Sub insert_rows()
    Dim LR As Long
    Dim Rng1 As Range
    Dim cel1 As Range
    Dim Rng2 As Range
    Dim FindString As String
    Dim FindString1 As String

    ActiveWorkbook.Names.Add Name:="Colours", RefersTo:="=OFFSET(Data!$H$3,0,0,(COUNTA(Data!$H:$H)-1),1)"
    LR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row

    Set Rng1 = Sheets("Data").Range("Colours")
    For Each cel1 In Rng1
        FindString = cel1.Value
        If Trim(FindString) <> "" Then
            With Sheet1.Range("A3:A" & LR)
                Set Rng2 = .Find(What:=FindString, _
                        After:=.Cells(.Cells.Count), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
                If Not Rng2 Is Nothing Then
                    GoTo SkipMe
                Else
                    FindString1 = cel1.Offset(1, 0).Value
                    Set Rng2 = .Find(What:=FindString1, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
                    If Not Rng2 Is Nothing Then
                        Application.Goto Rng2, True
                        Rng2.EntireRow.Insert
                        ActiveCell.Value = FindString
                        Range(ActiveCell.Address).Resize(1, 8).Name = FindString
                        Range(ActiveCell.Address).Resize(1, 8).Interior.ColorIndex = 0
                        LR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
                    End If
                End If
            End With
        End If
SkipMe:
    Next cel1
End Sub