Hi
Untested.
Code:Option Explicit Sub kTest() Dim SourceFolder As String Dim wbkSource As Workbook Dim wbkDest As Workbook Dim FName As String Dim rngSource As Range Dim wksDest As Worksheet SourceFolder = "C:\Test" '<<< adjust the folder If Right$(SourceFolder, 1) <> "\" Then SourceFolder = SourceFolder & "\" FName = Dir(SourceFolder & "*.xls*") Set wbkDest = ThisWorkbook Application.ScreenUpdating = 0 Set wksDest = wbkDest.Worksheets(wbkDest.Worksheets.Count) Do While Not FName = vbNullString If Not FName = wbkDest.Name Then Set wbkSource = Workbooks.Open(SourceFolder & FName, 0) Set rngSource = wbkSource.Worksheets(1).Range("a1").CurrentRegion Set wksDest = wbkDest.Worksheets.Add(, wksDest) rngSource.Copy wksDest.Range("a1") wksDest.Name = FName End If wbkSource.Close 0 Set wbkSource = Nothing FName = Dir() Loop Application.ScreenUpdating = 1 End Sub




Reply With Quote
Bookmarks