Sub proba1()

Dim i, j As Integer ' для циклов
Application.ScreenUpdating = False

Sheets("sheet2").Select
For Each i In Range("B17:B26")
If i <> Empty Then counter = counter + 1
Next 'подсчет непустых ячеек

Sheets("sheet1").Select
Rows(3).Copy ' Копирование строки 3
Range("B2").Select
Selection.End(xlDown).Select
a = Selection.Row ' выделение последней непустой ячейки

For j = 1 To counter
Rows(a + j).Select
ActiveSheet.Paste 'Вставка counter раз
Next
Range("B3").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy ' Копирование строк

Sheets("sheet4").Select
Range("B3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub