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