DoCmd.TransferText acImportDelim, , tblName, [red]InputDir & "\" & [/red]ImportFile
Sub AggregateFile()
On Error GoTo AggregateFile_Exit
'[b]Change this to the real directory[/b]
Const cstFilePath As String = "C:\"
Dim intIn As Integer, intOut As Integer, intTemp As Integer
Dim strFileName As String
Dim strIn As String, strTemp As String
'make an output directory
MkDir cstFilePath & "Out"
'create the output file
intOut = FreeFile
Open cstFilePath & "Out\Temp.csv" For Output As #intTemp
'Get the first file and make sure it exists
strFileName = Dir(cstFilePath & "*.csv")
If strFileName = "" Then GoTo AggregateFile_Exit
'Open the file
intIn = FreeFile
Open cstFilePath & strFileName For Input As #intIn
'Write data from the first in file to the out file
Do
Line Input #intIn, strIn
Write #intTemp, strIn
Loop Until EOF(intIn)
intTemp = FreeFile
'Do the rest of the files
Do While strFileName <> ""
Reset
strFileName = Dir
Open cstFilePath & "Out\Temp.csv" For Input As #intTemp
Open cstFilePath & strFileName For Input As #intIn
Open cstFilePath & "Out\All.csv" For Output As #intOut
Do
Line Input #intTemp, strTemp
Line Input #intIn, strIn
'If you need double quotes around the fields
'add them below ... & Chr(34) & strIn & Chr(34)
Write #intOut, strTemp & "," & strIn
Loop Until EOF(intIn)
Kill cstFilePath & "Out\Temp.csv"
FileCopy cstFilePath & "Out\All.csv", cstFilePath & "Out\Temp.csv"
Kill cstFilePath & "Out\All.csv"
Loop
AggregateFile_Exit:
Reset
Exit Sub
AggregateFile_Error:
Stop
End SubPublic Function AggregateFile(ByVal FilePath As String, ByVal FilePattern As String) As Double
Dim intIn As Integer
Dim intOut As Integer
Dim intTemp As Integer
Dim nLines As Long
Dim FileName As String
Dim strIn As String
Dim strTemp As String
Dim tm As Double
tm = Timer
On Error GoTo AggregateFile_Error
If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"
'make an output directory
If Len(Dir(FilePath & "Out", vbDirectory)) = 0 Then MkDir FilePath & "Out"
FileName = Dir(FilePath & FilePattern)
If FileName = "" Then
MsgBox "No files found for " & FilePath & FilePattern
GoTo AggregateFile_Exit
End If
'create the output file
With New FileSystemObject
.CopyFile FilePath & FileName, FilePath & "Out\Temp.Txt", True
End With
'Do the rest of the files
FileName = Dir
Do While FileName <> ""
intTemp = FreeFile: Open FilePath & "Out\Temp.Txt" For Input As #intTemp
intIn = FreeFile: Open FilePath & FileName For Input As #intIn
intOut = FreeFile: Open FilePath & "Out\All.Txt" For Output As #intOut
nLines = 0
Do Until EOF(intIn) Or EOF(intTemp)
nLines = nLines + 1
If Not EOF(intTemp) Then Line Input #intTemp, strTemp
If Not EOF(intIn) Then Line Input #intIn, strIn
If Len(strTemp) = 0 Then
Exit Do
ElseIf Len(strIn) = 0 Then
Print #intOut, strTemp & " ?"
Else
Print #intOut, strTemp & " " & strIn
End If
strTemp = ""
strIn = ""
Loop
Close
With New FileSystemObject
.DeleteFile FilePath & "Out\Temp.Txt"
.MoveFile FilePath & "Out\All.Txt", FilePath & "Out\Temp.Txt"
End With
FileName = Dir
Loop
AggregateFile_Exit:
If Dir(FilePath & "Out\All.Txt") <> "" Then Kill FilePath & "Out\All.Txt"
AggregateFile = Timer - tm
Exit Function
AggregateFile_Error:
MsgBox Err.Number & " - " & Err.Description
Close
GoTo AggregateFile_Exit
End FunctionSub AggregateFile()
On Error GoTo AggregateFile_E[b]rror[/b]
'Change this to the real directory
Const cstFilePath As String = "C:\PhD\Data\SAUP\2003SpeDistributions[b][red]\[/red][/b]"
...
