Here's some code that you can adapt
Code:
Option Explicit
'---------------------------------------------------------------------------------------
' Module : Data
' Author : Roy Cox (royUK)
' Website : for more examples and Excel Consulting
' Date : 19/11/2011
' Purpose : Combine data from several workbooks
' Disclaimer: Disclaimer; This code is offered as is with no guarantees. You may use it in your
' projects but please leave this header intact.
'---------------------------------------------------------------------------------------
Option Explicit
Sub CombineData()
Dim oWbk As Workbook
Dim uRng As Range
Dim rToCopy As Range
Dim rNextCl As Range
Dim lCount As Long
Dim bHeaders As Boolean
Dim sFil As String
Dim sPath As String
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
' On Error GoTo exithandler
sPath = ThisWorkbook.Path & Application.PathSeparator & "Data"
ChDir sPath
sFil = Dir("*.xlsx") 'change or add formats
Do While sFil <> "" 'will start LOOP until all files in folder sPath have been looped through
With ThisWorkbook.Worksheets(1)
Set uRng = .UsedRange
If uRng.Cells.Count = 0 Then
'no data in master sheet
bHeaders = False
Else: bHeaders = True
End If
Set oWbk = Workbooks.Open(sPath & Application.PathSeparator & sFil) 'opens the file
Set rToCopy = oWbk.ActiveSheet.UsedRange
If Not bHeaders Then
Set rNextCl = .Cells(1, 1)
bHeaders = True
Else: Set rNextCl = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
'headers exist so don't copy
Set rToCopy = rToCopy.Offset(1, 0).Resize(rToCopy.Rows.Count - 1, _
rToCopy.Columns.Count)
End If
rToCopy.Copy rNextCl
End With
oWbk.Close False 'close source workbook
sFil = Dir
Loop ' End of LOOP
'sort to remove empty rows
Set uRng = ThisWorkbook.Worksheets(1).UsedRange
uRng.Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
exithandler:
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
End Sub
Bookmarks