Sub Макрос6()
    ActiveSheet.Shapes.Range(Array("Рисунок в прямоугольнике")).Select
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.IncrementTop 60.8723622047
    Selection.ShapeRange.ScaleHeight 0.7831753405, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 174
    Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 280
    Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 0
    Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = -30
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.ScaleHeight 0.7163249388, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 174
    Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 280
    Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 0
    Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = 0
    Range("A1").Select
End Sub

Sub readtxt()
Dim FileNameTxt$: FileNameTxt = "D:\15\1.txt"
Dim meData(), i&, sStr$
Dim filenum&: filenum = FreeFile()

LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
MsgBox "Заполненные ячейки в столбце А: " & Range("A1:A" & LastRow).Address

Open FileNameTxt For Input As #filenum
Do Until EOF(filenum)
Line Input #filenum, sStr
If InStr(1, sStr, "РАЗДЕЛИТЕЛЬ ТЕКСТА") Then 'если нашли строку то
Do 'считываем в массив
1000 Line Input #filenum, sStr
i = i + 1
ReDim Preserve meData(1 To i)
meData(i) = sStr
If EOF(filenum) Then GoTo ExitSub 'если конец файла, то выходим
Loop While InStr(1, sStr, "РАЗДЕЛИТЕЛЬ ТЕКСТА") = 0 'находим следующее вхождение - выходим
i = 0
ReDim meData(1 To 1)
GoTo 1000
End If
Loop
ExitSub:
Close #filenum
ActiveSheet.Range(Cells(LastRow + 1, 1), Cells(UBound(meData), 1)) = Application.Transpose(meData) 'выводим массив на активный лист
End Sub