Windows("1.xlsx.xlsm").Activate
    Range("A1:W40").Copy
    Windows("Книга1").Activate
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

Sub CopyAndTransposeTable()
  Dim sh As Worksheet
  Dim myArr(), LastRow&
  For Each sh In ThisWorkbook.Sheets
    If sh.Name <> ActiveSheet.Name Then
      myArr = sh.UsedRange.Offset(, 1).Resize(, sh.UsedRange.Columns.Count - 1)
      myArr = TransposeArray(myArr)
      With ActiveSheet
        LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
        .Cells(LastRow, 2).Resize(UBound(myArr, 1), UBound(myArr, 2)) = myArr
        .Cells(LastRow, 1).Resize(UBound(myArr, 1)) = sh.Name
      End With
    End If
  Next sh
End Sub

Function TransposeArray(ByRef SourceArray() As Variant) As Variant
    Dim X1&: X1 = LBound(SourceArray, 1)
    Dim X2&: X2 = UBound(SourceArray, 1)
    Dim Y1&: Y1 = LBound(SourceArray, 2)
    Dim Y2&: Y2 = UBound(SourceArray, 2)
    Dim TempArray As Variant, i&, j&
    ReDim TempArray(Y1 To Y2, X1 To X2)
    For i = X1 To X2
        For j = Y1 To Y2
            TempArray(j, i) = SourceArray(i, j)
        Next j
    Next i
    TransposeArray = TempArray
End Function