This code places data from one worksheet, in all of the files opened, onto one master sheet in the workbook containing the code.
You must specify the sheet name or sheet number (position)... "vCopyFrom" and "vCopyTo"
You must specify the complete file path to the specific folder.
It uses Like "*.xls*" to process any .xls or .xlsx or .xlsm files it finds.
Code: Select all
Sub ConsolidateFiles()
'Jim Cone - Portland, Oregon USA - last modified April 2016.
On Error GoTo ThatHurt
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim strPath As String
Dim strName As String
Dim vCopyTo As Variant
Dim vCopyFrom As Variant
Dim blnTask As Boolean
Dim lngRow As Long
Dim rngUsed As Excel.Range
Dim rngCell As Excel.Range
Dim WB As Excel.Workbook
If Val(Application.Version) >= 10 And Val(Application.Version) < 15 Then
blnTask = Application.ShowWindowsInTaskbar
Application.ShowWindowsInTaskbar = False
End If
Application.ScreenUpdating = False
'Specify the folder...
strPath = "C:\Excel Files\Commercial Projects\Brie Larson" '<<< CHANGE
'Can use worksheet position or worksheet name
vCopyTo = 1
vCopyFrom = 1
'Use Microsoft Scripting runtime.
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strPath)
'Check type of file in the folder and open file.
For Each objFile In objFolder.Files
If objFile.Name Like "*.xls*" Then
strName = objFile.Name
Application.StatusBar = strName
With ThisWorkbook.Worksheets(vCopyTo)
lngRow = .UsedRange.Rows.Count
lngRow = .UsedRange.Rows(lngRow).Row + 3
.Cells(lngRow - 1, 1).Resize(1, 2).Interior.Color = vbGreen
.Cells(lngRow - 1, 1).Value = strName
End With
Set WB = Workbooks.Open(objFile)
Set rngUsed = WB.Worksheets(vCopyFrom).UsedRange
Set rngCell = rngUsed.Cells(rngUsed.Rows.Count, rngUsed.Columns.Count)
Set rngUsed = rngUsed.Parent.Range("A1", rngCell)
rngUsed.Copy Destination:=ThisWorkbook.Worksheets(vCopyTo).Cells(lngRow, 1)
WB.Close savechanges:=False
End If
Next 'objFile
CloseOut:
On Error Resume Next
If blnTask Then Application.ShowWindowsInTaskbar = blnTask
Application.StatusBar = False
Application.ScreenUpdating = True
Set objFile = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
Set rngCell = Nothing
Set rngUsed = Nothing
Set WB = Nothing
Exit Sub
ThatHurt:
Beep
MsgBox "Error " & Err.Number & " " & Err.Description, , "Consolidate Files"
Resume CloseOut
End Sub
'---
Jim Cone
https://goo.gl/IUQUN2" onclick="window.open(this.href);return false; (Dropbox)