Sub Main()
Dim FSO As Object, ts As Object
Dim txtFile, fName As String, sTmp As String
Dim n As Long, lPos As Long, t As Double, X As Long
On Error GoTo ErrHandler
txtFile = Application.GetOpenFilename("Text Files (*.txt), *.txt", , , , True)
[COLOR=#ff0000]If TypeName(txtFile) = "Variant()" Then[/COLOR]
[COLOR=#0000cd]Set FSO = CreateObject("Scripting.FileSystemObject")[/COLOR]
t = Timer
Application.ScreenUpdating = False
For X = LBound(txtFile) To UBound(txtFile)
If FSO.GetFile(txtFile(X)).Size > 0 Then
fName = FSO.GetFile(txtFile(X)).Name
fName = Left(fName, Len(fName) - 4)
Set ts = FSO.OpenTextFile(txtFile(X), 1)
sTmp = ts.ReadAll
ts.Close: Set ts = Nothing
If Left(sTmp, 2) <> vbCrLf Then sTmp = vbCrLf & sTmp
If Right(sTmp, 2) <> vbCrLf Then sTmp = sTmp & vbCrLf
Dim lPos1 As Long, lPos2 As Long
lPos1 = InStr(1, sTmp, vbCrLf)
lPos2 = InStr(1, sTmp, ",")
If (lPos1 * lPos2) Then
Dim arr(1 To 1000000, 1 To 4)
[COLOR=#ff0000]n = 0[/COLOR]
Do While lPos2
n = n + 1
arr(n, 1) = n
arr(n, 2) = Mid(sTmp, lPos1 + 2, 3)
lPos1 = InStr(lPos2, sTmp, vbCrLf)
arr(n, 3) = Mid(sTmp, lPos2 + 1, lPos1 - lPos2 - 1)
arr(n, 4) = fName
lPos2 = InStr(lPos1, sTmp, ",")
Loop
If n Then Range("A1000000").End(xlUp).Offset(1).Resize(n, 4).Value = arr
End If
End If
Next
Application.ScreenUpdating = True
End If
MsgBox Timer - t, , n & " items"
[COLOR=#0000cd]Set FSO = Nothing[/COLOR]
Exit Sub
ErrHandler: MsgBox Err.Description
[COLOR=#ff0000]Set FSO = Nothing[/COLOR]
End Sub
