[vba]Код
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
[/vba]