Need to append data from multiple workbooks

I have multiple single sheet workbooks in a folder. I need to import/append the data in each workbook to a new sheet named "Imported Data" in the macro workbook. The folder contains only the source data and the macro workbook. I'll need to run the macro weekly in different folders so I don't want the file path hard coded. I'd like the macro to import files in the 'active directory'.

The source sheets are alike. They all have the same headers in rows 1-4. I want to copy the header rows from one workbook (it doesn't matter which one) to the new sheet. Then I want to copy and append the real data (100 rows) in row 5 to 104 to the new sheet.

Note: There is data in the source files after row 104, but I do not want to import it.

Your assistance will be greatly appreciated!

-- DJ
Excel 2007

Hello there, welcome to the board!

We're assuming a lot here. I know you're using 2007. Does that mean all files are in 2007 format? Will there ever be any .xls files? What if you have more than one sheet with the same name? Would you want to rename these sheets? What of the new file? Shall it be saved to the same directory? And what exactly do you mean by the "active directory"? You mean the directory the active workbook is in? Is this code going into a specific workbook in another location? Are you wanting to copy the data from only column A?

I've addressed these issues in the code, via assumption of course. The code below will create a new file (unsaved) with a worksheet named as you desired (Imported Data). It will open every file in the specified folder from a browse window (routine cancelled if the user clicks the cancel button or does not specify a folder), all 97-2010 files will be imported, only the data from the left-most sheet is grabbed, and only the data in column A. The header from A1:A4 is grabbed from the first workbook seen, then all the data from that and every other workbook from A5:A104 and copied to the new worksheet. All data will be appended below the previous data. Currently there is no check to see if you're at the end of the column. So if you're using a 2007 or up file format, I hope you don't have more than 1 million rows of data to be copied. It runs in about 2 seconds for a dozen files in one folder for me. Also currently it does not do child folders.

Lightly tested...
Option Explicit

Const sFileType = "*.xls*"

Sub ConsolidateFiles()

Dim WB As Workbook, WS As Worksheet
Dim wbCopy As Workbook, wsCopy As Worksheet
Dim rCopy As Range, rHeader As Range
Dim strFileName As String, sName As String
Dim bHeader As Boolean, bWbOpened As Boolean
Dim vFolder As Variant, iRow As Long

vFolder = BrowseForFolder()
If vFolder = False Then Exit Sub

Call TOGGLEEVENTS(False)

Set WB = Workbooks.Add(xlWBATWorksheet)
Set WS = WB.Sheets(1)
WS.Name = "Imported Data"
strFileName = Dir$(vFolder & "\" & sFileType)
bHeader = False

Do Until strFileName = ""
sName = Right(strFileName, Len(strFileName) - InStrRev(strFileName, "\"))
If ISWBOPEN(sName) = True Then
Set wbCopy = Workbooks(sName)
bWbOpened = False
Else
Set wbCopy = Workbooks.Open(strFileName)
bWbOpened = True
End If
Set wsCopy = wbCopy.Sheets(1) '** ASSUMPTION
If bHeader = False Then
wsCopy.Range("A1:A4").Copy WS.Range("A1:A4")
bHeader = True
End If
iRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row + 1
wsCopy.Range("A5:A104").Copy WS.Range("A" & iRow).Resize(100, 1)
If bWbOpened = True Then wbCopy.Close False
strFileName = Dir$()
Loop

Call TOGGLEEVENTS(True)

End Sub

Function ISWBOPEN(strWbName As String) As Boolean
On Error Resume Next
ISWBOPEN = Len(Workbooks(strWbName).Name)
On Error GoTo 0
End Function

Public Sub TOGGLEEVENTS(blnState As Boolean)
'Originally written by firefytr
With Application
.DisplayAlerts = blnState
.EnableEvents = blnState
.ScreenUpdating = blnState
If blnState Then .CutCopyMode = False
If blnState Then .StatusBar = False
End With
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.Self.Path
On Error GoTo 0
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
BrowseForFolder = False
End Function

All of the code can be pasted into a standard module. Let us know how it goes.

HTH