Перенести (скопировать) согласно списка "блоки" (пронумерованные строки)

Sub proba()
Dim S As String
S = [a1]
Range(S).Copy Destination:=[a10]  'ячейка для вставки, которая вам нужна
End Sub

Dim LastRow As Long
Sub Bloks()
Dim I As Long, J As Long, K As Integer, N As Integer, M As Long
Sheets("результат").Select
Columns("A:H").Delete 'зачищаем столбцы результата
Sheets("данные").Select
Range("A1:H2").Copy Destination:=Sheets("результат").[A1]
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Call Sorty
K = 2: I = 3: J = 2: M = 3
Do While Sheets("список").Cells(K, 1) <> ""
  N = Sheets("список").Cells(K, 1)
  If Cells(I, 1) = N Then
    If I > J Then J = I
    Do While Cells(J + 1, 1) = N
      J = J + 1
    Loop
    Range(Cells(I, 1), Cells(J, "H")).Copy Destination:=Sheets("результат").Cells(M, 1)
    M = J + 1: I = M
  End If
  K = K + 1
Loop
End Sub
Sub Sorty()
'макрос сортировки записан рекодером
    Range("A3:H" & LastRow).Select
    ActiveWorkbook.Worksheets("данные").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("данные").Sort.SortFields.Add Key:=Range( _
        "A3:A" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("данные").Sort
        .SetRange Range("A2:H" & LastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Sub Bloks()
Dim I As Long, J As Long, K As Integer, N As Integer, M As Long
Sheets("результат").Select
Columns("A:H").Delete
Sheets("данные").Select
Range("A1:H2").Copy Destination:=Sheets("результат").[A1]
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Call Sorty
K = 2: I = 3: J = 2: M = 3
Do While Sheets("список").Cells(K, 1) <> ""
  N = Sheets("список").Cells(K, 1)
ToI:
  If Cells(I, 1) = N Then
    If I > J Then J = I
    Do While Cells(J + 1, 1) = N
      J = J + 1
    Loop
    Range(Cells(I, 1), Cells(J, "H")).Copy Destination:=Sheets("результат").Cells(M, 1)
    M = M + J - I + 1: I = J + 1
  Else
    I = I + 1: GoTo ToI
  End If
  K = K + 1
Loop
End Sub

   I = I + 1: If I > LastRow Then Exit Sub Else GoTo ToI