Returning range of values from all files in folder

[GDunn]

Hi,

I am trying to return a range of values ("F23:K23") from each sheet named ("Test") from each file in a folder named ("January 2011"), to a seperate worksheet.

Each time the refresh button is pressed the code should look at each file in the specified folder and return the range on each sheet named ("Test") within the files in the folder ("January 2011") to Sheet ("Master") - first file results on return to cells ("A1:F1"), second file results return to cell ("A2:F2") and so on...

No code of any use to offer at this time. Can anyone help?

Thanks

 

[Sektor]

Private Sub ReturnData()

    ' Set reference to library: Tools -> Reference -> Microsoft Scripting Runtime

    Dim fso As New FileSystemObject, aFile As File
    Dim wkb As Workbook, sh As Worksheet, this As Worksheet
    
    Set this = Worksheets("Master")
    
    For Each aFile In fso.GetFolder("C:\January 2011").Files
        If fso.GetExtensionName(aFile.Name) Like "xls*" Then
            Set wkb = Workbooks.Open(aFile.Path)
            Set sh = wkb.Sheets("Test")
            sh.Range("F23:K23").Copy this.Cells(this.Rows.Count, "A").End(xlUp).Offset(1, 0)
            wkb.Close SaveChanges:=False
        End If
    Next

    this.Rows(1).EntireRow.Delete
    
End Sub

 

[GDunn]

Dim fso As New FileSystemObject, aFile As file
is returning Compile Error: User-defined type not defined

+ do I need to do anything re: this comment?
' Set reference to library: Tools -> Reference -> Microsoft Scripting Runtime

Thanks

 

[Sektor]

See comment. And also change path to your folder:

For Each aFile In fso.GetFolder("[B][COLOR="Red"]C:\January 2011[/COLOR][/B]").Files

 

[GDunn]

Apologies, I do not understand comment

Have changed folder references

 

[Sektor]

Comments begin with apostrophe and Rem keyword.
For example:

Sub SubWithComments
   ' This is comment. I begin with apostrophe.
   Rem This is comment too. I begin with Rem keyword.
End Sub

So, you should go to Tools -> References and check "Microsoft Scripting Runtime". Good luck!

 

[GDunn]

Thanks, works great.

How would I pastespecial values the returned results?

 

[Sektor]

Private Sub ReturnData()

    Dim fso As New FileSystemObject, aFile As File
    Dim wkb As Workbook, sh As Worksheet, this As Worksheet
    
    ' Set reference to library: Tools -> Reference -> Microsoft Scripting Runtime
    Set this = Worksheets("Master")
    
    For Each aFile In fso.GetFolder("C:\January 2011").Files
        If fso.GetExtensionName(aFile.Name) Like "xls*" Then
            Set wkb = Workbooks.Open(aFile.Path)
            Set sh = wkb.Sheets("Test")
            [B][COLOR="Red"]sh.Range("F23:K23").Copy
            this.Cells(this.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues[/COLOR][/B]
            wkb.Close SaveChanges:=False
        End If
    Next

    this.Rows(1).Delete
    
End Sub

 

[Richard Schollar]

Change this line:

sh.Range("F23:K23").Copy this.Cells(this.Rows.Count, "A").End(xlUp).Offset(1, 0)

to this:

sh.Range("F23:K23").Copy 
this.Cells(this.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues