Identifying text file names and importing on single Excel sheet

Question

Hey!
Does anybody can help me with Excel VBA macro code in order to import data from text files into single Excel spread sheet? I want to create User Form where user can select start and end date of interest and macro code will import
bunch of text files depending on user demands...
My text files are named: 20130619004948DataLog.txt (meaning: yyyy mm dd hh mm ss). Text file contains recordings for each 15 seconds... It would be great to omit time tail (meaning that user can only specify date). Text files for one day of interest (I have
text files covering whole year):
20130619004948DataLog.txt
20130619014948DataLog.txt
20130619024948DataLog.txt
20130619034948DataLog.txt
20130619044948DataLog.txt
20130619054948DataLog.txt
20130619064948DataLog.txt
20130619074948DataLog.txt
20130619084948DataLog.txt
20130619094948DataLog.txt
20130619104948DataLog.txt
20130619114948DataLog.txt
20130619124948DataLog.txt
20130619134948DataLog.txt
20130619144948DataLog.txt
20130619154948DataLog.txt
20130619164948DataLog.txt
20130619174948DataLog.txt
20130619184948DataLog.txt
20130619194948DataLog.txt
20130619204948DataLog.txt
20130619214948DataLog.txt
20130619224948DataLog.txt
20130619234948DataLog.txt
Option Explicit
Sub SearchFiles()
Dim file As Variant
Dim x As Integer
Dim myWB As Workbook
Dim WB As Workbook
Dim newWS As Worksheet
Dim L As Long, t As Long, i As Long
Dim StartDateL As String
Dim EndDateL As String
Dim bool As Boolean
bool = False ' to check if other versions are present
StartDateL = Format(Calendar1, "yyyymmdd")
EndDateL = Format(Calendar2, "yyyymmdd")
' I am using Userform asking user to select the date and time range of interet,
' However, I want to use only the date to filter the files having the name with that particular date
file = Dir("c:\myfolder\") ' folder with all text files
' I need assistance with the following part:
'1) How to filter and select the files between StartDateL and EndDateL_
'(including files with that dates as well)?
While (file <> "")
If InStr(file, StartDateL) > 0 Then 'Not sure if the statements inside parenthesis is correct
bool = True
GoTo Line1:
End If
file = Dir
Wend
Line1:
If Not bool Then
file = "c:\myfolder\20130115033100DataLog.txt" 'Just for a test that the code works as intended
End If
'This part for the selected text files to be loaded on a single Excel Sheet.
Set myWB = ThisWorkbook
Set newWS = Sheets(1)
L = myWB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
t = 1
For x = 1 To UBound(file)
Workbooks.OpenText Filename:=file(x), DataType:=xlDelimited, Tab:=True, Semicolon:=True, Space:=False, Comma:=False
Set WB = ActiveWorkbook
WB.Sheets(1).UsedRange.Copy newWS.Cells(t, 2)
t = myWB.Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row + 1
WB.Close False
Next
myWB.Sheets(1).Columns(1).Delete
Application.ScreenUpdating = False
Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub

Answer 1

- Make a new Excel file
- Open the VBA editor
- Add a Userform
- Place 2 text boxes and 1 command button on that form
- Paste all code below into the code module of the form
- Download this file:
https://dl.dropboxusercontent.com/u/35239054/FileSearch.cls
- In the VBA editor press CTRL-M and import that file
- Save the Excel file in the directory that contain your text files
- Run the form
You can format the columns of the sheet as you like, e.g. column E:H should be a number with 5 decimal places. The top row can contain some headings. My code did not affect the formatting or the headings.
Andreas.
Option Explicit
Private Sub UserForm_Initialize()
'Just a sample
Me.TextBox1.Value = FormatDateTime(Now, vbGeneralDate)
Me.TextBox2.Value = FormatDateTime(Now, vbShortDate)
End Sub
Private Sub CommandButton1_Click()
Dim StartDate As Date, EndDate As Date
Dim FS As New FileSearch
Dim R As Range
Dim ThisFile As Variant
Dim ThisDate As Date
Dim Data As Variant
Dim Count As Long
'Be sure we have 2 dates
If Not IsDate(Me.TextBox1.Value) Then
Me.TextBox1.SetFocus
MsgBox "No start date"
Exit Sub
End If
If Not IsDate(Me.TextBox2.Value) Then
Me.TextBox2.SetFocus
MsgBox "No end date"
Exit Sub
End If
'Convert to real dates
StartDate = CDate(Me.TextBox1.Value)
EndDate = CDate(Me.TextBox2.Value)
'Time part given?
If Fix(EndDate) = EndDate Then
'No include all files for this day
EndDate = EndDate + TimeSerial(23, 59, 59)
End If
'Correct order?
If StartDate > EndDate Then
ThisDate = EndDate
EndDate = StartDate
StartDate = ThisDate
End If
With FS
'Same path as our file
.LookIn = ThisWorkbook.Path
.FileName = "*DataLog.txt"
'Search all files sort by file name
If .Execute(msoSortByFileName, msoSortOrderAscending) = 0 Then
MsgBox "No data files found in " & .LookIn
Exit Sub
End If
'Clear previous data
Set R = Range("A2").CurrentRegion
If R.Row < 2 Then Set R = R.Offset(1)
R.ClearContents
'Show the user that we are working
Application.Cursor = xlWait
DoEvents
For Each ThisFile In .FoundFiles
'Get the date from the file name
ThisDate = Filename2Date(ThisFile)
'Between our dates?
If (ThisDate >= StartDate) And (ThisDate <= EndDate) Then
'Import at the end of the data
Set R = Range("A" & Rows.Count).End(xlUp).Offset(1)
Data = ReadCSV(ThisFile)
R.Resize(UBound(Data) + 1, UBound(Data, 2) + 1) = Data
Count = Count + 1
End If
Next
End With
'Done
Application.Cursor = xlDefault
If Count = 0 Then
MsgBox "No files match your dates"
Else
MsgBox Count & " files imported"
'Hide the form
Me.Hide
End If
End Sub
Private Function Filename2Date(ByVal Fullname As String) As Date
'Convert e.g "C:\20130601142648DataLog.txt" to the date "01.06.2013 14:26:48"
Dim i As Long, j As Long
i = InStrRev(Fullname, "\")
If i > 0 Then Fullname = Mid(Fullname, i + 1)
Fullname = JustNumbers(Fullname)
If Len(Fullname) <> 14 Then Exit Function
Filename2Date = _
DateSerial(Mid(Fullname, 1, 4), Mid(Fullname, 5, 2), Mid(Fullname, 7, 2)) + _
TimeSerial(Mid(Fullname, 9, 2), Mid(Fullname, 11, 2), Mid(Fullname, 13, 2))
End Function
Private Function JustNumbers(ByVal What As String) As String
'Return only numbers from What (by Rick Rothstein)
Dim i As Long, j As Long, Digit As String
For i = 1 To Len(What)
Digit = Mid$(What, i, 1)
If Digit Like "#" Then
j = j + 1
Mid$(What, j, 1) = Digit
End If
Next
JustNumbers = Left$(What, j)
End Function
Private Function ReadCSV(ByVal Fullname As String) As Variant
'Read a CSV file into an array
Const LDelim = vbCrLf 'Line delimiter
Const FDelim = ";" 'Field delimiter
Dim hFile As Integer
Dim Buffer As String
Dim Lines, Line, Data
Dim i As Long, j As Long
'Be sure the file exists
If Dir(Fullname) = "" Then Exit Function
'Open and read all data
hFile = FreeFile
Open Fullname For Binary Access Read As #hFile
Buffer = Space(LOF(hFile))
Get #hFile, , Buffer
Close #hFile
'Split into lines
Lines = Split(Buffer, LDelim)
'Split the first line and prepare the output
'Note: I assume that all lines have the same number of fields
Line = Split(Lines(0), FDelim)
ReDim Data(0 To UBound(Lines), 0 To UBound(Line))
For i = 0 To UBound(Lines)
Line = Split(Lines(i), FDelim)
For j = 0 To UBound(Line)
'Parse the fields
If IsDate(Line(j)) Then
Data(i, j) = CDate(Line(j))
ElseIf IsNumeric(Line(j)) Then
Data(i, j) = CDbl(Line(j))
Else
Data(i, j) = Line(j)
End If
Next
Next
ReadCSV = Data
End Function