Sub Main
Call AppendData
End Sub
Function GetFolder(ByVal DefaultPath As String)
On Error Resume Next
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
jmp1:
jmp1:
With fd
.InitialFileName = DefaultPath & "\"
.Show
End With
.InitialFileName = DefaultPath & "\"
.Show
End With
GetFolder = fd.SelectedItems(1)
If GetFolder = Empty Then GoTo errHandler
Exit Function
errHandler:
MsgBox "Please select a folder."
GoTo jmp1
If GetFolder = Empty Then GoTo errHandler
Exit Function
errHandler:
MsgBox "Please select a folder."
GoTo jmp1
End Function
Sub AppendData()
Dim folderpath As String
Dim cnt As DAO.Database
Dim rst As DAO.Recordset
Dim cnt As DAO.Database
Dim rst As DAO.Recordset
Sheets(1).Select
Range("A2").Select
Range("A2").Select
folderpath = GetFolder("C:")
With Application.FileSearch
.NewSearch
.LookIn = folderpath
.SearchSubFolders = False
.Filename = "*.xls"
.Execute
For i = 1 To .FoundFiles.Count
Set cnt = DBEngine.OpenDatabase(.FoundFiles(i), False, False, "Excel 8.0")
Set rst = cnt.OpenRecordset("Sheet1$")
.NewSearch
.LookIn = folderpath
.SearchSubFolders = False
.Filename = "*.xls"
.Execute
For i = 1 To .FoundFiles.Count
Set cnt = DBEngine.OpenDatabase(.FoundFiles(i), False, False, "Excel 8.0")
Set rst = cnt.OpenRecordset("Sheet1$")
ActiveCell.CopyFromRecordset rst
Cells(Range("E1").End(xlDown).Row + 1, 1).Select
Cells(Range("E1").End(xlDown).Row + 1, 1).Select
rst.Close
cnt.Close
Next
End With
cnt.Close
Next
End With
End Sub
For worksheet example check this url http://groups.google.co.in/group/myvbagroup?hl=en
See the Web's breaking stories, chosen by people like you. Check out Yahoo! Buzz.