Кажется, вы делаете определенные шаги из 7 строк. Поэтому, возможно, попробуйте:
Sub Test()
Dim lr As Long, x As Long
With ThisWorkbook.Worksheets("Sheet1") 'Change accordingly
'Find last used row
lr = .Cells(.Rows.Count, 6).End(xlUp).Row
'Step through data and transpose values
For x = 2 To lr Step 7
.Cells(x, 8).Resize(2, 7).Value = Application.Transpose(.Range(.Cells(x, 6), .Cells(x + 6, 7)).Value)
Next x
End With
End Sub
Или, если вас действительно интересуют значения и формат копирования и вставки:
Sub Test()
Dim lr As Long, x As Long
With ThisWorkbook.Worksheets("Sheet1") 'Change accordingly
'Find last used row
lr = .Cells(.Rows.Count, 6).End(xlUp).Row
'Step through data
For x = 2 To lr Step 7
.Range(.Cells(x, 6), .Cells(x + 6, 7)).Copy
.Cells(x, 8).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Next x
End With
End Sub