slow reading a file

[larrydave]

Hello; I apologize if this is a duplicate post, but I posted over an hour ago
and it has not shown up yet.

I have a macro that imports a large text file into every fourth column.
Last week it ran fairly fast; this week it crawls. I estimate today that it
would take nearly 7 hours to import this file; last week to took 10 - 15
seconds. I haven't made any code changes, so I do not know what is wrong.
The size of the file keeps, growing - maybe that is the problem. I have even
tried using a better pc - still the same issue. Here is my code; I would
appreciate if someone who knows what they are doing would see if there is
something that could be changed to speed things up.

Sub Autpen()
MsgBox "Hello"
Columns("a:ir").EntireColumn.Clear
Dim FileName As String
Dim ResultStr As String
Dim FileNum As Integer
Dim Counter As Double
FileName = Application.GetOpenFilename
Application.ScreenUpdating = False
If FileName = "False" Then End
FileNum = FreeFile()
Open FileName For Input As #FileNum
Sheet1.Cells(2, 1).Select
Counter = 1
ColCounter = 4

Do While Seek(FileNum) <= LOF(FileNum)
If EOF(FileNum) Then End
Application.StatusBar = "Reading Row " & Counter & " of text file " &
FileName
Line Input #FileNum, ResultStr

ActiveCell.Value = ResultStr
If ActiveCell.Row = 65536 Then
ColCounter = ColCounter + 1
Sheet1.Cells(2, ColCounter).Select
Else
ActiveCell.Offset(1, 0).Select
End If
Counter = Counter + 1

Loop
Close
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub

When I end the macro, the debugger stops at this line:

If ActiveCell.Row = 65536 Then

Any help and ideas would be greatly appreciated.

Thank you.

 

[Peter T]

Have a go with the following

Option Explicit
Sub Test()
' MsgBox "Hello"
Dim FileName As String
Dim ResultStr As String
Dim FileNum As Integer
Dim Counter As Long, rec As Long
Dim j As Long, k As Long
Dim ColCounter As Long
Dim ws As Worksheet
Const MAXARR As Long = 22000

Set ws = ThisWorkbook.Worksheets("Sheet1")
' or codename
' Set ws = ThisWorkbook.Sheet1
With ws
Application.Intersect(.UsedRange, .Columns("a:ir")).Clear
Debug.Print .UsedRange.Count
End With
FileName = Application.GetOpenFilename

' FileName = "C:\temp\bigfile.txt"
' Application.ScreenUpdating = False

If FileName = "False" Then End
FileNum = FreeFile

Open FileName For Input As #FileNum
' ws.Cells(2, 1).Select ' not necessary
Counter = 0
ColCounter = 4
j = 2
k = MAXARR

ReDim arr(1 To k, 1 To 1)

Do While Seek(FileNum) <= LOF(FileNum)
If EOF(FileNum) Then ' not necessary
Exit Do
End If

Counter = Counter + 1
rec = rec + 1
If rec / 100 = Int(rec / 100) Then
' Application.StatusBar = "Reading Row " & rec & " of text file "
& FileName
End If
Line Input #FileNum, arr(Counter, 1)

If Counter = UBound(arr) Then

ws.Cells(j, ColCounter).Resize(k).Value = arr

j = j + UBound(arr)
If j >= ws.Rows.Count Then
ColCounter = ColCounter + 1
j = 2
End If

k = MAXARR
If j + k > ws.Rows.Count Then
k = ws.Rows.Count - j + 1
End If

ReDim arr(1 To k, 1 To 1)
Counter = 0

End If

Loop

Close #FileNum

If Counter Then
ws.Cells(j, ColCounter).Resize(UBound(arr)).Value = arr
End If

Application.ScreenUpdating = True
Application.StatusBar = False
End Sub


I made a text file to test with this

Sub MakeBigFile()
Dim sFile As String
Dim FF As Integer
sFile = "C:\temp\bigfile.txt" ' assumes C:\Temp\ exists
On Error Resume Next
Kill sFile
On Error GoTo 0
FF = FreeFile
Open sFile For Append As #FF
For i = 1 To 65535 * 10 + 10
Print #FF, "Item " & CStr(i)
Next
Close #FF
End Sub


BTW, NEVER use the "End" statement. Also it's rarely necessary to select
cells, the above writes dumps in chunks of up to 22k at a time which is
faster than writing to individual cells. You could try 65536 but that would
only give a small advantage but could end up hogging memory.

If while testing things seems to get very slow, quit Excel and start again.

(Probably faster to read the entire string into an array in one go then re
assign into columns up to the row limit)

Regards,
Peter T