Do you want to append all files without first checking for duplicates? If you need to check for duplicates you'll need to cycle through each source sheet 1 row at a time and will need to modify the code below for that.
Put all source files in the same folder. In this case, in C:\SourceXLS:
-------------------------------------------------------------
Private Sub PullFiles_Button_Click()
'Processes worksheets in sDir copying them to FullList Tab
Dim oTarget As Worksheet, oSource As Worksheet, sOpenWB As String, sThisWB As String
Dim sDir As String, iStartRow As Long, bNoError As Boolean
sThisWB = ActiveWorkBook.FullName
sThisWB = Right(sThisWB, Len(sThisWB) - Len(ActiveWorkbook.Path) - 1)
sDir = "C:\SourceXLS"
Set oTarget = Workbooks(sThisWB).Worksheets("FullList")
sOpenWB = Dir(sDir & "\*.xls") 'Gets First file from directory of all *.xls files in sDir folder
If sOpenWB = sThisWB Then sOpenWB = Dir 'Gets Next File if current is this master workbook
if sOpenWB = "" Then
MsgBox "No XLS files found in folder or bad path",,No Data Files Found"
Exit Sub
End If
iStartRow = 2 'Pastes starting at row 2 assuming that titles are row 1
Do While sOpenWB <> ""
bNoError = OpenSource(sDir & "\" & sOpenWB)
If Not bNoError Then
MsgBox "Error Opening Workbook " & sDir & "\" & sOpenWB & ", check path / Filename and try again", _
"File Open Error"
Exit Sub 'Halts processing on first failure to read file that should exist
End If
Set oSource = Workbooks(sOpenWB).ActiveSheet 'Assumes active sheet on opening workbook is only 1 to copy
oSource.Range("A2:G2").Select 'Assumes Data is in columns A to G and data starts in row 2 no empty rows
oSource.Selection.End(xlDown).Select 'Selects all records going down until empty row
oSource.Selection.Copy Destination:=oTarget.Cells(iStartRow, 1)
iStartRow = oTarget.Range("A2").End(xlDown).Row
Workbooks(sOpenWB).Close SaveChanges:=False
sOpenWB = Dir 'Gets Next File
If sOpenWB = sThisWB Then sOpenWB = Dir 'Gets Next File if current is this master workbook
Loop
End Sub
Private Function OpenSource(sToOpen As String) As Boolean
'Tries to open file and returns false if fails
On Error GoTo FailedOpenSource
Workbooks.Open FileName:=sToOpen
On Error GoTo 0
OpenSource = True
FailedOpenSource:
End Function
-------------------------------------------------------------
This is pretty simplistic but it should point you in the right direction.
Hope this helped.
|
