Макрос преобразования таблицы в список

Option Explicit

Private Sub ScreensOFF()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual 'Это поможет при наличии завязанных на редактируемые данные формул
    Application.EnableCancelKey = xlDisabled ' Fix for Code execution has been interrupted
End Sub

Private Sub ScreensON()
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic 'Это поможет при наличии завязанных на редактируемые данные формул
End Sub

Sub GoMyWork()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim iLastRow As Integer
    Dim iLastCol As Integer
    Dim i, j, r
    Set sh1 = Sheets("Один ролик")
    Set sh2 = Sheets("c"): sh2.range("A2:H5000").ClearContents
    ScreensOFF
    With sh1
        iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        iLastCol = .Cells(3, .Columns.Count).End(xlToLeft).Column
        r = 2
        For i = 4 To iLastRow
            For j = .Range("CD1").Column To iLastCol
                If .Cells(i, j) <> "" Then
                    r = r + 1
                    sh2.Cells(r, "A") = .Cells(3, j)
                    sh2.Cells(r, "B") = .Cells(i, "B")
                    sh2.Cells(r, "C") = .Cells(i, "C")
                    sh2.Cells(r, "D") = .Cells(i, "D")
                    sh2.Cells(r, "E") = .Cells(i, "E")
                    sh2.Cells(r, "F") = .Cells(i, "F")
                    sh2.Cells(r, "G") = .Cells(i, "G")
                    sh2.Cells(r, "H") = .Cells(i, j)
                End If
            Next j
        Next i
    End With
    ScreensON
    Set sh1 = Nothing
    Set sh2 = Nothing
End Sub