Macro to get specific cell data from multiple workbooks

[Apokalipto]

Hi to everyone, i have searched around to find the specific macro that i can use to solve my issue but nothing works, so i need a modified macro to help me get cell values from multiple files in one folder C:\workbooks (.xclx) the concrete cells i need to get data from are A1 E59 E60 etc. (i will modify this one to apply i just need working example) the work books are all same and the sheet name is same example: XXXXX

EDIT:
Forgot to mention that the data from each workbook must come in new row.

 

[mumps]

Could upload a copy of your destination file and one or two of your source files to a free site such as www.box.com or www.dropbox.com. Once you do that, mark each file for 'Sharing' and you will be given a link to each file that you can post here. If the workbooks contains confidential information, you could replace it with generic data.

 

[mumps]

Change the sheet name in the source workbooks to "Sheet1" and try this macro:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wsDest As Worksheet, wsSrc As Worksheet, wkbSrc As Workbook
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    Const strPath As String = "C:\workbooks\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSrc = Workbooks.Open(strPath & strExtension)
        Set wsSrc = Sheets("Sheet1")
        With wsSrc
            .Range("A1").Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Range("E58:E64").Copy
            wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True, Paste:=xlPasteValues
            .Range("H58:H64").Copy
            wsDest.Cells(wsDest.Rows.Count, "I").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True, Paste:=xlPasteValues
            .Range("K58:K64").Copy
            wsDest.Cells(wsDest.Rows.Count, "P").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True, Paste:=xlPasteValues
            .Range("N58:N64").Copy
            wsDest.Cells(wsDest.Rows.Count, "W").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True, Paste:=xlPasteValues
            .Range("Q58:Q64").Copy
            wsDest.Cells(wsDest.Rows.Count, "AD").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True, Paste:=xlPasteValues
        End With
        wkbSrc.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[Apokalipto]

We have a winner!

Change the sheet name in the source workbooks to "Sheet1" and try this macro:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wsDest As Worksheet, wsSrc As Worksheet, wkbSrc As Workbook
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    Const strPath As String = "C:\workbooks\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSrc = Workbooks.Open(strPath & strExtension)
        Set wsSrc = Sheets("Sheet1")
        With wsSrc
            .Range("A1").Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Range("E58:E64").Copy
            wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True, Paste:=xlPasteValues
            .Range("H58:H64").Copy
            wsDest.Cells(wsDest.Rows.Count, "I").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True, Paste:=xlPasteValues
            .Range("K58:K64").Copy
            wsDest.Cells(wsDest.Rows.Count, "P").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True, Paste:=xlPasteValues
            .Range("N58:N64").Copy
            wsDest.Cells(wsDest.Rows.Count, "W").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True, Paste:=xlPasteValues
            .Range("Q58:Q64").Copy
            wsDest.Cells(wsDest.Rows.Count, "AD").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True, Paste:=xlPasteValues
        End With
        wkbSrc.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[mumps]

Glad it worked out.