Trying to copy a certain range from several worksheets and paste into one worksheet as transposed, with each column in one line

Question

Trying to copy the same range from all worksheets, and paste transposed into one worksheet. I want to get one line for each column in the destination worksheet. What I have tried so far looks like this:

Sub contracts()
Dim sh As Worksheet
Dim wb As Workbook
Dim DestSh As Worksheet
Dim DestShLastRow As Long
Dim i As Integer
Application.ScreenUpdating = False
    Set wb = ActiveWorkbook
    Set DestSh = wb.Sheets("Total table")
    DestShLastRow = DestSh.Cells(DestSh.Rows.Count, "A").End(xlUp).Offset(1).Row
    i = 1
    For Each sh In ActiveWorkbook.Worksheets
    If sh.Name = "Total table" Then Exit Sub
        sh.Range("h3:h14").Copy
        DestSh.Range ("a" & i)
        .PasteSpecial xlPasteValues
        .PasteSpecial Transpose = True
        Application.CutCopyMode = False
        End With
    i = i + 1
    Next
Application.ScreenUpdating = True 
End Sub

When I run this code, I get an

1004-error, saying that "PasteSpecial method of Range class failed.

Anyone who has any advice on how to solve this problem?

Answer 1

Try changing your code, in the iteration part, in this way:

Dim arr As Variant
For Each sh In ActiveWorkbook.Worksheets
    If sh.Name = "Total table" Then Exit For
    arr = sh.Range("h3:h14").Value
    DestSh.Range("a" & i).Resize(, UBound(arr, 1)).Value = _
                             WorksheetFunction.Transpose(arr)
    i = i + 1
 Next