Macro to search column, copy row and insert

[Reimertoad]

I'm attempting to create a macro that will search a range of values, and insert a row directly underneath any of the values found - via an input box.

In column F, I have a list of employees' 'Start Times'. I want to create an input box that prompts me to enter a specific start time (there are 37), and once it finds an exact match of that particular value it will A) copy the entire row in which it was found, B) insert the entire row directly underneath (including the formulas), and C) shade the new row in yellow.

I already have the below code which will find every example of the start time '1200-2000' ONLY and then insert a blank underneath where found;

Sub BlankLine()
    Dim Col As Variant
    Dim BlankRows As Long
    Dim LastRow As Long
    Dim R As Long
    Dim StartRow As Long
Dim LSearchRow As Integer
   Dim LCopyToRow As Integer
   LSearchValue = InputBox("Please enter a Start Time.", "Enter value")

        Col = "F"
        StartRow = 1
        BlankRows = 1
            LastRow = Cells(Rows.Count, Col).End(xlUp).Row
            Application.ScreenUpdating = False
            With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = "1200-2000" Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
End With
Application.ScreenUpdating = True
End Sub

As I have so many start times (all with a '****-****' format like '1200-2000' used in the above), can the above be modified to accommodate, or does it need to be done as a range? Also, how/where/what do I enter the code for copying the data from the whole row (once it's successfully found a searched value), and inserting that copied data in a new row directly underneath?

The working file is attached with a 'before' and 'after' on how I'd ideally like it to appear.

Many thanks in advance!!

[mdmackillop]

Well presented question, thanks.

If .Cells(R, Col) = "1200-2000" Then
                .Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
                .Cells(R + 1, Col).EntireRow.FillDown
                .Cells(R + 1, Col).EntireRow.Interior.ColorIndex = 6
            End If

[mdmackillop]

Here's a version which will prompt for all times prior to insertion. If you just want to do all then delete the Chk routine

Sub BlankLine2()


    Dim Col As Variant
    Dim BlankRows As Long
    Dim LastRow As Long
    Dim R As Long
    Dim StartRow As Long
    Dim LSearchRow As Long
    Dim LCopyToRow As Long
    Dim Dic As Object, k
    Dim Rng As Range, cel As Range
    Dim Chk As Long
        
        Col = "F"
        StartRow = 1
        BlankRows = 1
        LastRow = Cells(Rows.Count, Col).End(xlUp).Row
        Application.ScreenUpdating = False
      Set Dic = CreateObject("Scripting.Dictionary")
      With ActiveSheet
       Set Rng = Range(.Cells(23, "F"), .Cells(LastRow, "F"))
        
        'Get unique times
        On Error Resume Next
        For Each cel In Rng
            If cel <> "" Then Dic.Add CStr(cel), Null
        Next cel
        On Error GoTo 0
        
        For Each k In Dic.keys
         Chk = MsgBox("Insert after " & k, vbQuestion + vbYesNoCancel)        If Chk = vbCancel Then Exit For
        If Chk = vbYes Then
            LastRow = Cells(Rows.Count, Col).End(xlUp).Row
            For R = LastRow To StartRow + 1 Step -1
                If .Cells(R, Col) = k Then
                    .Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
                    .Cells(R + 1, Col).EntireRow.FillDown
                    .Cells(R + 1, Col).EntireRow.Interior.ColorIndex = 6
                End If
            Next R
        End If
        Next k
    End With
    Application.ScreenUpdating = True


End Sub