VBA importing data from .txt

[allen4pyd]

Hi,

I've only recently began learning vba due to a new job. However I could do with some help with a macro that's to technical for me to write

Basically I have a few hundred .txt files in the format as follows:
13 January 2012 01:45:00 8.2100
13 January 2012 02:00:00 8.1500
13 January 2012 02:15:00 8.1800
13 January 2012 02:30:00 8.1000
13 January 2012 02:45:00 8.1000

What I'd like to do is import ONLY the last number, line by line so it can be imported into a table...

Now, im not sure if this is possible but I would like it to loop through a selected folder file by file in the order they appear

Thanks for any help in advance :)

[patel]

attach please a small sample result file and one text file

[Kenneth Hobs]

That is not difficult but requires a few steps. How do you define the order of the files as they appear? Is it by file modified date, file created date, filename etc.?

Where would the data be inserted, next empty cell in Column A on the current sheet, etc.?

[allen4pyd]

Kenneth Hobs

The files appear in order as their filename.
For example: "1 Filename", "2 Filename", "2 Filename (1)", "2 Filename (2), "3 Filename", "4 Filename"
Note there is more than one file under the name "2 filename", this occurs quite often throughout.

Yes, after the first file is inserted, the first line of the next file would ideally go on the next free line of that column

Thanks

[Kenneth Hobs]

Change what you need in the first sub and run it. Note that numbers like 9.1000 will be added as 9.1. You can always set a numberformat if needed.


Sub insertTXTdata() Dim r As Range
Dim a() As Variant, vA As Variant
Dim b() As String
Dim c() As String, sC As String
Dim i As Integer
Dim sPath As String, sCol As String

sPath = ThisWorkbook.Path
sCol = "A"
Set r = Range(sCol & "1").End(xlUp).Offset(1)

a() = GetFileList(sPath & "\*.txt")
a() = SortArray(a)
For Each vA In a()
b() = Split(StrFromTXTFile(sPath & "\" & vA), vbCrLf)
For i = LBound(b) To UBound(b)
c() = Split(b(i))
r.Value = c(UBound(c))
'r.NumberFormat = "#.0000"
Set r = r.Offset(1)
Next i
Next vA

End Sub




Function StrFromTXTFile(filePath As String) As String
Dim str As String, hFile As Integer

If Dir(filePath) = "" Then
StrFromTXTFile = "NA"
Exit Function
End If

hFile = FreeFile
Open filePath For Binary Access Read As #hFile
str = Input(LOF(hFile), hFile)
Close hFile

StrFromTXTFile = str
End Function


Function GetFileList(FileSpec As String) As Variant
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False


Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String

On Error GoTo NoFilesFound


FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound

' Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function


' Error handler
NoFilesFound:
GetFileList = False
End Function


Public Function SortArray(ByRef MyArray As Variant, Optional Order As Long = xlAscending) As Variant
Dim w As Worksheet
Dim r As Range

Set w = ThisWorkbook.Worksheets.Add()

On Error Resume Next
Range("A1").Resize(UBound(MyArray, 1), 1) = WorksheetFunction.Transpose(MyArray)
Range("A1").Resize(UBound(MyArray, 1), UBound(MyArray, 2)) = WorksheetFunction.Transpose(MyArray)
Set r = w.UsedRange
If Order = xlAscending Then
r.Sort Key1:=r.Cells(1, 1), Order1:=xlAscending
Else
r.Sort Key1:=r.Cells(1, 1), Order1:=xlDescending
End If

SortArray = r

Set r = Nothing
Application.DisplayAlerts = False
w.Delete
Application.DisplayAlerts = True
Set w = Nothing
End Function

[snb]

I'd try:


Sub M_snb()
c00 = "G:\OF\*.txt"

For Each it In Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & c00 & """ /b").stdout.readall, vbCrLf)
c01 = c01 & vbLf & Join(Filter(Split(Replace(CreateObject("scripting.filesystemobject").opentextfile(it).readall, vbCrLf, ",")), "."), vblf)
Next
sn = Split(Mid(c01, 2), vbLf)

Sheets("sheet1").Cells(1).Resize(UBound(sn) + 1) = Application.Transpose(sn)
End Sub