'Option Explicit Public files() Dim sExcelPathLocation As String Dim name1 As String Dim ino As String Dim dbname1 As String Sub Main 'get the folder info sExcelPathLocation = BrowseFolder() If (FindFiles(sExcelPathLocation & "\", "xlsx", files) = True) Then count = UBound(files) For i = 0 To count Set task = Client.GetImportTask("ImportExcel" ) task.FirstRowIsFieldName = "TRUE" task.FileToImport = sExcelPathLocation & "\" & files(i) Dim excel As Object Dim oBook As Object Dim sSheetName As String Set excel = CreateObject("Excel.Application") excel.Visible = False Set oBook = excel.Workbooks.Open(sExcelPathLocation & "\" & files(i)) 'store the name of the first worksheet sSheetName = oBook.Worksheets(1).Name Set oBook = Nothing excel.quit 'exit excel Set excel = Nothing sample_prefix = Left(files(i), (Len(files(i)) - 4)) ' Removes Extension task.OutputFilePrefix = sample_prefix If(i=0) Then name1=sample_prefix+"-"+sSheetName+".IMD" End If task.EmptyNumericFieldAsZero = FALSE task.UniqueFilePrefix 'Execute the import task.PerformTask If(i=1) Then Set db = Client.OpenDatabase(name1) Set task = db.AppendDatabase task.AddDatabase sample_prefix+"-"+sSheetName+".IMD" ino = CStr(i) dbName = sample_prefix+"Appended"+ino+".IMD" task.PerformTask dbName, "" Set task = Nothing Set db = Nothing Client.CloseDatabase sample_prefix+"-"+sSheetName+".IMD" Client.DeleteDatabase(sample_prefix+"-"+sSheetName+".IMD") Client.CloseDatabase name1 Client.DeleteDatabase(name1) dbname1 = dbName End If If(i>1) Then Set db = Client.OpenDatabase(dbname1) Set task = db.AppendDatabase task.AddDatabase sample_prefix+"-"+sSheetName+".IMD" ino = CStr(i) dbName = sample_prefix+"Appended"+ino+".IMD" task.PerformTask dbName, "" Set task = Nothing Set db = Nothing Client.CloseDatabase sample_prefix+"-"+sSheetName+".IMD" Client.DeleteDatabase(sample_prefix+"-"+sSheetName+".IMD") Client.CloseDatabase dbname1 Client.DeleteDatabase(dbname1) dbname1 = dbName End If Next i End If client.refreshFileExplorer MsgBox "Done" Client.OpenDatabase (dbName) End Sub Function BrowseFolder() Dim oFolder, oFolderItem Dim oPath, oShell, strPath Dim msg As String Set oShell = CreateObject( "Shell.Application" ) Set oFolder = oShell.Namespace(17) Set oFolderItem = oFolder.Self strPath = oFolderItem.Path msg = "Please select the directory" Set oFolder = oShell.BrowseForFolder(0, msg, 1, strPath ) If oFolder Is Nothing Then BrowseFolder = "" Exit Function End If Set oFolderItem = oFolder.Self oPath = oFolderItem.Path BrowseFolder = oPath End Function Private Function FindFiles(path As String, ext As String, files()) Dim ffile As String ffile = Dir$(path & "*." & ext) If Len(ffile) = 0 Then Exit Function '-------- Dir ext = *.ext* fixing by checking length Do firstbackspace = strReverse (ffile) firstbackspacenum = InStr(1,firstbackspace, ".") importname = Right(ffile, firstbackspacenum - 1) If Len(importname) = Len(ext) Then If Not IsNull(ffile) Then '-------- If one value found return function true and redim array If (FindFiles = False) Then ReDim files(0) FindFiles = True Else ReDim Preserve files(UBound(files) + 1) End If files(UBound(files)) = ffile Else Exit Do End If End If ffile = Dir Loop Until Len(ffile) = 0 End Function