Option Explicit
Sub Макрос1() ' надо вызывать этот макрос
Const FromPageName = "Sheet3" ' имя страницы, на которой расположены исходные данные
Const ToPageName = "Result" ' имя страницы, на которую пишем (должна существовать)
Const FromPageStartRow = 3 ' номер строки, с которой начинаем искать
Const FromPageFinishRow = 9 ' номер строки, на которой заканчиваем искать
Const FromPageStartCol = 2 ' номер колонки, с которой начинаем искать (он-же содержит наименование)
Const FromPageFinishCol = 6 ' номер колонки, на которой заканчиваем искать

Dim FromPage As Worksheet
Dim ToPage As Worksheet

Dim NumCol As Integer
Dim NumRow As Integer
Dim TargetRow As Integer

Set FromPage = ActiveWorkbook.Worksheets(FromPageName)
Set ToPage = ActiveWorkbook.Worksheets(ToPageName)

' очистка ToPage
ToPage.Activate
ToPage.Rows("2:" + Trim(Str(ToPage.Rows.Count))).Select
Selection.Delete Shift:=xlUp
' переброска
TargetRow = 2
For NumRow = FromPageStartRow To FromPageFinishRow
For NumCol = FromPageStartCol + 1 To FromPageFinishCol ' первую колонку пропускаем - она содержит наименование
If FromPage.Cells(NumRow, NumCol).Formula <> "" Then ' берем только непустые ячейки
' копируем заголовок
CopyCells FromPage, NumRow, FromPageStartCol, ToPage, TargetRow, 1
' копируем ячейку к этому заголовку
CopyCells FromPage, NumRow, NumCol, ToPage, TargetRow, 2
TargetRow = TargetRow + 1
End If
Next
Next
End Sub
' а этот макрос вызывать ручками не надо. Да и не получится.
Private Sub CopyCells(FromPage As Worksheet, FromRow As Integer, FromCol As Integer, ToPage As Worksheet, ToRow As Integer, ToCol As Integer)
FromPage.Activate
FromPage.Cells(FromRow, FromCol).Select
Selection.Copy
ToPage.Activate
ToPage.Cells(ToRow, ToCol).Select
ActiveSheet.Paste
End Sub