Вариант с выбором редактируемого файла, последний должен быть закрыт (проверяет до 1 строки)
[vba]Код
Public Sub insStr()
Dim i As Integer
Dim j
Dim rng1 As Range
Dim fName As String, bkStartName As String
Const lName As String = "Лист1"
Const startRow As Integer = 1
fName = "False"
bkStartName = ThisWorkbook.Name
With Worksheets(lName)
Set rng1 = Range("A5:G29")
j = .Cells(4, 1).Font.Color
End With
fName = Application.GetOpenFilename
If fName <> "False" Then
Workbooks.Open Filename:=fName
With ActiveWorkbook.Worksheets(lName)
i = .Cells(Rows.Count, 1).End(xlUp).Row
For i = i To startRow Step -1
If .Cells(i, 1).Font.Color = j Then
.Cells(i + 1, 1).Select
Selection.Resize(rng1.Rows.Count).EntireRow.Insert Shift:=xlShiftDown
rng1.Copy Destination:=Selection
End If
Next i
End With
ActiveWorkbook.Close
End If
Workbooks(bkStartName).Activate
End Sub
[/vba]